summaryrefslogtreecommitdiffstats
path: root/generic/tclIORChan.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIORChan.c')
-rw-r--r--generic/tclIORChan.c3187
1 files changed, 3187 insertions, 0 deletions
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
new file mode 100644
index 0000000..ca3ab4b
--- /dev/null
+++ b/generic/tclIORChan.c
@@ -0,0 +1,3187 @@
+/*
+ * tclIORChan.c --
+ *
+ * This file contains the implementation of Tcl's generic channel
+ * reflection code, which allows the implementation of Tcl channels in
+ * Tcl code.
+ *
+ * Parts of this file are based on code contributed by Jean-Claude
+ * Wippler.
+ *
+ * See TIP #219 for the specification of this functionality.
+ *
+ * Copyright (c) 2004-2005 ActiveState, a divison of Sophos
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include <tclInt.h>
+#include <tclIO.h>
+#include <assert.h>
+
+#ifndef EINVAL
+#define EINVAL 9
+#endif
+#ifndef EOK
+#define EOK 0
+#endif
+
+/*
+ * 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);
+
+/*
+ * The C layer channel type/driver definition used by the reflection. This is
+ * a version 3 structure.
+ */
+
+static Tcl_ChannelType tclRChannelType = {
+ "tclrchannel", /* 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. NULL'able */
+ ReflectSetOption, /* Set options. NULL'able */
+ ReflectGetOption, /* Get options. NULL'able */
+ ReflectWatch, /* Initialize notifier */
+ NULL, /* Get OS handle from the channel. NULL'able */
+ NULL, /* No close2 support. NULL'able */
+ ReflectBlock, /* Set blocking/nonblocking. NULL'able */
+ NULL, /* Flush channel. Not used by core. NULL'able */
+ NULL, /* Handle events. NULL'able */
+ ReflectSeekWide, /* Move access point (64 bit). NULL'able */
+ NULL, /* thread action */
+ NULL, /* truncate */
+};
+
+/*
+ * Instance data for a reflected channel. ===========================
+ */
+
+typedef struct {
+ Tcl_Channel chan; /* Back reference to generic channel
+ * structure. */
+ Tcl_Interp *interp; /* Reference to the interpreter containing the
+ * Tcl level part of the channel. NULL here
+ * signals the channel is dead because the
+ * interpreter/thread containing its Tcl
+ * command is gone.
+ */
+#ifdef TCL_THREADS
+ Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */
+#endif
+
+ /* 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 interest; /* Mask of events the channel is interested
+ * in. */
+
+ /*
+ * Note regarding the usage of timers.
+ *
+ * Most channel implementations need a timer in the C level to ensure that
+ * data in buffers is flushed out through the generation of fake file
+ * events.
+ *
+ * See 'rechan', 'memchan', etc.
+ *
+ * Here this is _not_ required. Interest in events is posted to the Tcl
+ * level via 'watch'. And posting of events is possible from the Tcl level
+ * as well, via 'chan postevent'. This means that the generation of all
+ * events, fake or not, timer based or not, is completely in the hands of
+ * the Tcl level. Therefore no timer here.
+ */
+} ReflectedChannel;
+
+/*
+ * Structure of the table maping from channel handles to reflected
+ * channels. Each interpreter which has the handler command for one or more
+ * reflected channels records them in such a table, so that 'chan postevent'
+ * is able to find them even if the actual channel 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;
+} ReflectedChannelMap;
+
+#define RCMKEY "ReflectedChannelMap"
+
+/*
+ * Event literals. ==================================================
+ */
+
+static const char *eventOptions[] = {
+ "read", "write", NULL
+};
+typedef enum {
+ EVENT_READ, EVENT_WRITE
+} EventOption;
+
+/*
+ * Method literals. ==================================================
+ */
+
+static const char *methodNames[] = {
+ "blocking", /* OPT */
+ "cget", /* OPT \/ Together or none */
+ "cgetall", /* OPT /\ of these two */
+ "configure", /* OPT */
+ "finalize", /* */
+ "initialize", /* */
+ "read", /* OPT */
+ "seek", /* OPT */
+ "watch", /* */
+ "write", /* OPT */
+ NULL
+};
+typedef enum {
+ METH_BLOCKING,
+ METH_CGET,
+ METH_CGETALL,
+ METH_CONFIGURE,
+ METH_FINAL,
+ METH_INIT,
+ METH_READ,
+ METH_SEEK,
+ METH_WATCH,
+ METH_WRITE
+} MethodName;
+
+#define FLAG(m) (1 << (m))
+#define REQUIRED_METHODS \
+ (FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH))
+#define NULLABLE_METHODS \
+ (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \
+ FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL))
+
+#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 {
+ ForwardedClose,
+ ForwardedInput,
+ ForwardedOutput,
+ ForwardedSeek,
+ ForwardedWatch,
+ ForwardedBlock,
+ ForwardedSetOpt,
+ ForwardedGetOpt,
+ ForwardedGetOptAll
+} 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 ForwardParamInput {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ char *buf; /* O: Where to store the read bytes */
+ int toRead; /* I: #bytes to read,
+ * O: #bytes actually read */
+};
+struct ForwardParamOutput {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ const char *buf; /* I: Where the bytes to write come from */
+ int toWrite; /* I: #bytes to write,
+ * O: #bytes actually written */
+};
+struct ForwardParamSeek {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ int seekMode; /* I: How to seek */
+ Tcl_WideInt offset; /* I: Where to seek,
+ * O: New location */
+};
+struct ForwardParamWatch {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ int mask; /* I: What events to watch for */
+};
+struct ForwardParamBlock {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ int nonblocking; /* I: What mode to activate */
+};
+struct ForwardParamSetOpt {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ const char *name; /* Name of option to set */
+ const char *value; /* Value to set */
+};
+struct ForwardParamGetOpt {
+ ForwardParamBase base; /* "Supertype". MUST COME FIRST. */
+ const char *name; /* Name of option to get, maybe NULL */
+ Tcl_DString *value; /* Result */
+};
+
+/*
+ * Now join all these together in a single union for convenience.
+ */
+
+typedef union ForwardParam {
+ ForwardParamBase base;
+ struct ForwardParamInput input;
+ struct ForwardParamOutput output;
+ struct ForwardParamSeek seek;
+ struct ForwardParamWatch watch;
+ struct ForwardParamBlock block;
+ struct ForwardParamSetOpt setOpt;
+ struct ForwardParamGetOpt getOpt;
+} 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 */
+ ReflectedChannel *rcPtr; /* 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. */
+ /*
+ * Note regarding 'dsti' above: Its information is also available via the
+ * chain evPtr->rcPtr->interp, however, as can be seen, two more
+ * indirections are needed to retrieve it. And the evPtr may be gone,
+ * breaking the chain.
+ */
+ 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 channels owned by this thread. This is the
+ * per-thread version of the per-interpreter map.
+ */
+
+ ReflectedChannelMap* rcmPtr;
+} 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(rcForwardMutex)
+
+/*
+ * 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 ExitProc ensures that things do not deadlock when the sending thread
+ * involved in the forwarding exits. It also clean things up so that we don't
+ * leak resources when threads go away.
+ */
+
+static void ForwardOpToOwnerThread(ReflectedChannel *rcPtr,
+ 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 ReflectedChannelMap * GetThreadReflectedChannelMap(void);
+static void DeleteThreadReflectedChannelMap(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 int EncodeEventMask(Tcl_Interp *interp,
+ const char *objName, Tcl_Obj *obj, int *mask);
+static Tcl_Obj * DecodeEventMask(int mask);
+static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp,
+ Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj);
+static Tcl_Obj * NextHandle(void);
+static void FreeReflectedChannel(ReflectedChannel *rcPtr);
+static int InvokeTclMethod(ReflectedChannel *rcPtr,
+ const char *method, Tcl_Obj *argOneObj,
+ Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
+
+static ReflectedChannelMap * GetReflectedChannelMap(Tcl_Interp *interp);
+static void DeleteReflectedChannelMap(ClientData clientData,
+ Tcl_Interp *interp);
+static int ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj);
+
+/*
+ * 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_unsup = "{read not supported by Tcl driver}";
+static const char *msg_read_toomuch = "{read delivered more than requested}";
+static const char *msg_write_unsup = "{write not supported by Tcl driver}";
+static const char *msg_write_toomuch = "{write wrote more than requested}";
+static const char *msg_write_nothing = "{write wrote nothing}";
+static const char *msg_seek_beforestart = "{Tried to seek before origin}";
+#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}";
+
+/*
+ * Main methods to plug into the 'chan' ensemble'. ==================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChanCreateObjCmd --
+ *
+ * This function is invoked to process the "chan create" 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
+TclChanCreateObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ ReflectedChannel *rcPtr; /* Instance data of the new channel */
+ Tcl_Obj *rcId; /* Handle of the new channel */
+ int mode; /* R/W mode of new channel. Has to match
+ * abilities of handler commands */
+ Tcl_Obj *cmdObj; /* Command prefix, list of words */
+ Tcl_Obj *cmdNameObj; /* Command name */
+ Tcl_Channel chan; /* Token for the new 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. */
+ Channel *chanPtr; /* 'chan' resolved to internal struct. */
+ Tcl_Obj *err; /* Error message */
+ ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
+ Tcl_HashEntry* hPtr; /* Entry in the above map */
+ int isNew; /* Placeholder. */
+
+ /*
+ * Syntax: chan create MODE CMDPREFIX
+ * [0] [1] [2] [3]
+ *
+ * Actually: rCreate MODE CMDPREFIX
+ * [0] [1] [2]
+ */
+
+#define MODE (1)
+#define CMD (2)
+
+ /*
+ * Number of arguments...
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First argument is a list of modes. Allowed entries are "read", "write".
+ * Expect at least one list element. Abbreviations are ok.
+ */
+
+ modeObj = objv[MODE];
+ if (EncodeEventMask(interp, "mode", objv[MODE], &mode) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Second argument is command prefix, i.e. list of words, first word is
+ * name of handler command, other words are fixed arguments. Run the
+ * '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 channel.
+ */
+
+ rcId = NextHandle();
+ rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId);
+ chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr,
+ mode);
+ rcPtr->chan = chan;
+ chanPtr = (Channel *) chan;
+
+ /*
+ * Invoke 'initialize' and validate that the handler is present and ok.
+ * Squash the channel if not.
+ *
+ * Note: The conversion of 'mode' back into a Tcl_Obj ensures that
+ * 'initialize' is invoked with canonical mode names, and no
+ * abbreviations. Using modeObj directly could feed abbreviations into the
+ * handler, and the handler is not specified to handle such.
+ */
+
+ modeObj = DecodeEventMask(mode);
+ /* assert modeObj.refCount == 1 */
+ result = InvokeTclMethod(rcPtr, "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;
+ }
+
+ if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" lacks a \"read\" method", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" lacks a \"write\" method", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" supports \"cget\" but not \"cgetall\"", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
+ TclNewLiteralStringObj(err, "chan handler \"");
+ Tcl_AppendObjToObj(err, cmdObj);
+ Tcl_AppendToObj(err, "\" supports \"cgetall\" but not \"cget\"", -1);
+ Tcl_SetObjResult(interp, err);
+ goto error;
+ }
+
+ Tcl_ResetResult(interp);
+
+ /*
+ * Everything is fine now.
+ */
+
+ rcPtr->methods = methods;
+
+ if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) {
+ /*
+ * Some of the nullable methods are not supported. We clone the
+ * channel type, null the associated C functions, and use the result
+ * as the actual channel type.
+ */
+
+ Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)
+ ckalloc(sizeof(Tcl_ChannelType));
+
+ memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));
+
+ if (!(methods & FLAG(METH_CONFIGURE))) {
+ clonePtr->setOptionProc = NULL;
+ }
+
+ if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) {
+ clonePtr->getOptionProc = NULL;
+ }
+ if (!(methods & FLAG(METH_BLOCKING))) {
+ clonePtr->blockModeProc = NULL;
+ }
+ if (!(methods & FLAG(METH_SEEK))) {
+ clonePtr->seekProc = NULL;
+ clonePtr->wideSeekProc = NULL;
+ }
+
+ chanPtr->typePtr = clonePtr;
+ }
+
+ /*
+ * Register the channel in the I/O system, and in our our map for 'chan
+ * postevent'.
+ */
+
+ Tcl_RegisterChannel(interp, chan);
+
+ rcmPtr = GetReflectedChannelMap (interp);
+ hPtr = Tcl_CreateHashEntry(&rcmPtr->map,
+ chanPtr->state->channelName, &isNew);
+ if (!isNew) {
+ if (chanPtr != Tcl_GetHashValue(hPtr)) {
+ Tcl_Panic("TclChanCreateObjCmd: duplicate channel names");
+ }
+ }
+ Tcl_SetHashValue(hPtr, chan);
+#ifdef TCL_THREADS
+ rcmPtr = GetThreadReflectedChannelMap();
+ hPtr = Tcl_CreateHashEntry(&rcmPtr->map,
+ chanPtr->state->channelName, &isNew);
+ Tcl_SetHashValue(hPtr, chan);
+#endif
+
+ /*
+ * Return handle as result of command.
+ */
+
+ Tcl_SetObjResult(interp, rcId);
+ return TCL_OK;
+
+ error:
+ /*
+ * Signal to ReflectClose to not call 'finalize'.
+ */
+
+ rcPtr->methods = 0;
+ Tcl_Close(interp, chan);
+ return TCL_ERROR;
+
+#undef MODE
+#undef CMD
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclChanPostEventObjCmd --
+ *
+ * This function is invoked to process the "chan postevent" 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
+TclChanPostEventObjCmd(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const *objv)
+{
+ /*
+ * Syntax: chan postevent CHANNEL EVENTSPEC
+ * [0] [1] [2] [3]
+ *
+ * Actually: rPostevent CHANNEL EVENTSPEC
+ * [0] [1] [2]
+ *
+ * where EVENTSPEC = {read write ...} (Abbreviations allowed as well).
+ */
+
+#define CHAN (1)
+#define EVENT (2)
+
+ const char *chanId; /* Tcl level channel handle */
+ Tcl_Channel chan; /* Channel associated to the handle */
+ const Tcl_ChannelType *chanTypePtr;
+ /* Its associated driver structure */
+ ReflectedChannel *rcPtr; /* Associated instance data */
+ int events; /* Mask of events to post */
+ ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
+ Tcl_HashEntry* hPtr; /* Entry in the above map */
+
+ /*
+ * Number of arguments...
+ */
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First argument is a channel, a reflected channel, and the call of this
+ * command is done from the interp defining the channel handler cmd.
+ */
+
+ chanId = TclGetString(objv[CHAN]);
+
+ rcmPtr = GetReflectedChannelMap (interp);
+ hPtr = Tcl_FindHashEntry (&rcmPtr->map, chanId);
+
+ if (hPtr == NULL) {
+ Tcl_AppendResult(interp, "can not find reflected channel named \"", chanId,
+ "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CHANNEL", chanId, NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Note that the search above subsumes several of the older checks, namely:
+ *
+ * (1) Does the channel handle refer to a reflected channel ?
+ * (2) Is the post event issued from the interpreter holding the handler
+ * of the reflected channel ?
+ *
+ * A successful search answers yes to both. Because the map holds only
+ * handles of reflected channels, and only of such whose handler is
+ * defined in this interpreter.
+ *
+ * We keep the old checks for both, for paranioa, but abort now instead of
+ * throwing errors, as failure now means that our internal datastructures
+ * have gone seriously haywire.
+ */
+
+ chan = Tcl_GetHashValue(hPtr);
+ chanTypePtr = Tcl_GetChannelType(chan);
+
+ /*
+ * We use a function referenced by the channel type as our cookie to
+ * detect calls to non-reflecting channels. The channel type itself is not
+ * suitable, as it might not be the static definition in this file, but a
+ * clone thereof. And while we have reserved the name of the type nothing
+ * in the core checks against violation, so someone else might have
+ * created a channel type using our name, clashing with ourselves.
+ */
+
+ if (chanTypePtr->watchProc != &ReflectWatch) {
+ Tcl_Panic ("TclChanPostEventObjCmd: channel is not a reflected channel");
+ }
+
+ rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+ if (rcPtr->interp != interp) {
+ Tcl_Panic ("TclChanPostEventObjCmd: postevent accepted for call from outside interpreter");
+ }
+
+ /*
+ * Second argument is a list of events. Allowed entries are "read",
+ * "write". Expect at least one list element. Abbreviations are ok.
+ */
+
+ if (EncodeEventMask(interp, "event", objv[EVENT], &events) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ /*
+ * Check that the channel is actually interested in the provided events.
+ */
+
+ if (events & ~rcPtr->interest) {
+ Tcl_AppendResult(interp, "tried to post events channel \"", chanId,
+ "\" is not interested in", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * We have the channel and the events to post.
+ */
+
+ Tcl_NotifyChannel(chan, events);
+
+ /*
+ * Squash interp results left by the event script.
+ */
+
+ Tcl_ResetResult(interp);
+ return TCL_OK;
+
+#undef CHAN
+#undef EVENT
+}
+
+/*
+ * 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;
+}
+
+int
+TclChanCaughtErrorBypass(
+ Tcl_Interp *interp,
+ Tcl_Channel chan)
+{
+ Tcl_Obj *chanMsgObj = NULL;
+ Tcl_Obj *interpMsgObj = NULL;
+ Tcl_Obj *msgObj = NULL;
+
+ /*
+ * Get a bypassed error message from channel and/or interpreter, save the
+ * reference, then kill the returned objects, if there were any. If there
+ * are messages in both the channel has preference.
+ */
+
+ if ((chan == NULL) && (interp == NULL)) {
+ return 0;
+ }
+
+ if (chan != NULL) {
+ Tcl_GetChannelError(chan, &chanMsgObj);
+ }
+ if (interp != NULL) {
+ Tcl_GetChannelErrorInterp(interp, &interpMsgObj);
+ }
+
+ if (chanMsgObj != NULL) {
+ msgObj = chanMsgObj;
+ } else if (interpMsgObj != NULL) {
+ msgObj = interpMsgObj;
+ }
+ if (msgObj != NULL) {
+ Tcl_IncrRefCount(msgObj);
+ }
+
+ if (chanMsgObj != NULL) {
+ Tcl_DecrRefCount(chanMsgObj);
+ }
+ if (interpMsgObj != NULL) {
+ Tcl_DecrRefCount(interpMsgObj);
+ }
+
+ /*
+ * No message returned, nothing caught.
+ */
+
+ if (msgObj == NULL) {
+ return 0;
+ }
+
+ UnmarshallErrorResult(interp, msgObj);
+
+ Tcl_DecrRefCount(msgObj);
+ return 1;
+}
+
+/*
+ * 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)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ int result; /* Result code for 'close' */
+ Tcl_Obj *resObj; /* Result data for 'close' */
+ ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
+ Tcl_HashEntry* hPtr; /* Entry in the above map */
+
+ if (TclInThreadExit()) {
+ /*
+ * 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: DeleteThreadReflectedChannelMap() is the thread exit handler for the origin
+ * thread. Use this to clean up the structure? Except if lost?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p);
+ result = p.base.code;
+
+ /*
+ * FreeReflectedChannel is done in the forwarded operation!, in
+ * the other thread. rcPtr here is gone!
+ */
+
+ if (result != TCL_OK) {
+ FreeReceivedError(&p);
+ }
+ return EOK;
+ }
+#endif
+
+ Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ return EOK;
+ }
+
+ /*
+ * -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL)
+ *
+ * A cleaned method mask here implies that the channel creation was
+ * aborted, and "finalize" must not be called.
+ */
+
+ if (rcPtr->methods == 0) {
+ Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ return EOK;
+ }
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p);
+ result = p.base.code;
+
+ /*
+ * FreeReflectedChannel is done in the forwarded operation!, in the
+ * other thread. rcPtr here is gone!
+ */
+
+ if (result != TCL_OK) {
+ PassReceivedErrorInterp(interp, &p);
+ }
+ } else {
+#endif
+ result = InvokeTclMethod(rcPtr, "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 channel from the map before releasing the memory, to
+ * prevent future accesses (like by 'postevent') from finding and
+ * dereferencing a dangling pointer.
+ *
+ * NOTE: The channel may not be in the map. This is ok, that happens
+ * when the channel was created in a different interpreter and/or
+ * thread and then was moved here.
+ *
+ * NOTE: The channel may have been removed from the map already via
+ * the per-interp DeleteReflectedChannelMap exit-handler.
+ */
+
+ if (rcPtr->interp) {
+ rcmPtr = GetReflectedChannelMap (rcPtr->interp);
+ hPtr = Tcl_FindHashEntry (&rcmPtr->map,
+ Tcl_GetChannelName (rcPtr->chan));
+ if (hPtr) {
+ Tcl_DeleteHashEntry (hPtr);
+ }
+ }
+#ifdef TCL_THREADS
+ rcmPtr = GetThreadReflectedChannelMap();
+ hPtr = Tcl_FindHashEntry (&rcmPtr->map,
+ Tcl_GetChannelName (rcPtr->chan));
+ if (hPtr) {
+ Tcl_DeleteHashEntry (hPtr);
+ }
+#endif
+
+ Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+#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)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ Tcl_Obj *toReadObj;
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+ Tcl_Obj *resObj; /* Result data for '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 (!(rcPtr->methods & FLAG(METH_READ))) {
+ SetChannelErrorStr(rcPtr->chan, msg_read_unsup);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.input.buf = buf;
+ p.input.toRead = toRead;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedInput, &p);
+
+ if (p.base.code != TCL_OK) {
+ if (p.base.code < 0) {
+ /* No error message, this is an errno signal. */
+ *errorCodePtr = -p.base.code;
+ } else {
+ PassReceivedError(rcPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ }
+ p.input.toRead = -1;
+ } else {
+ *errorCodePtr = EOK;
+ }
+
+ return p.input.toRead;
+ }
+#endif
+
+ /* ASSERT: rcPtr->method & FLAG(METH_READ) */
+ /* ASSERT: rcPtr->mode & TCL_READABLE */
+
+ Tcl_Preserve(rcPtr);
+
+ toReadObj = Tcl_NewIntObj(toRead);
+ Tcl_IncrRefCount(toReadObj);
+
+ if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK) {
+ int code = ErrnoReturn (rcPtr, resObj);
+
+ if (code < 0) {
+ *errorCodePtr = -code;
+ goto error;
+ }
+
+ Tcl_SetChannelError(rcPtr->chan, resObj);
+ goto invalid;
+ }
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ if (toRead < bytec) {
+ SetChannelErrorStr(rcPtr->chan, msg_read_toomuch);
+ goto invalid;
+ }
+
+ *errorCodePtr = EOK;
+
+ if (bytec > 0) {
+ memcpy(buf, bytev, (size_t)bytec);
+ }
+
+ stop:
+ Tcl_DecrRefCount(toReadObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return bytec;
+ invalid:
+ *errorCodePtr = EINVAL;
+ error:
+ bytec = -1;
+ goto stop;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ Tcl_Obj *bufObj;
+ Tcl_Obj *resObj; /* Result data for 'write' */
+ int written;
+
+ /*
+ * 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 (!(rcPtr->methods & FLAG(METH_WRITE))) {
+ SetChannelErrorStr(rcPtr->chan, msg_write_unsup);
+ *errorCodePtr = EINVAL;
+ return -1;
+ }
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.output.buf = buf;
+ p.output.toWrite = toWrite;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedOutput, &p);
+
+ if (p.base.code != TCL_OK) {
+ if (p.base.code < 0) {
+ /* No error message, this is an errno signal. */
+ *errorCodePtr = -p.base.code;
+ } else {
+ PassReceivedError(rcPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ }
+ p.output.toWrite = -1;
+ } else {
+ *errorCodePtr = EOK;
+ }
+
+ return p.output.toWrite;
+ }
+#endif
+
+ /* ASSERT: rcPtr->method & FLAG(METH_WRITE) */
+ /* ASSERT: rcPtr->mode & TCL_WRITABLE */
+
+ Tcl_Preserve(rcPtr);
+
+ bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite);
+ Tcl_IncrRefCount(bufObj);
+
+ if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+ int code = ErrnoReturn(rcPtr, resObj);
+
+ if (code < 0) {
+ *errorCodePtr = -code;
+ goto error;
+ }
+
+ Tcl_SetChannelError(rcPtr->chan, resObj);
+ goto invalid;
+ }
+
+ if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) {
+ Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
+ goto invalid;
+ }
+
+ if ((written == 0) && (toWrite > 0)) {
+ /*
+ * The handler claims to have written nothing of what it was
+ * given. That is bad.
+ */
+
+ SetChannelErrorStr(rcPtr->chan, msg_write_nothing);
+ goto invalid;
+ }
+ if (toWrite < written) {
+ /*
+ * The handler claims to have written more than it was given. That is
+ * bad. Note that the I/O core would crash if we were to return this
+ * information, trying to write -nnn bytes in the next iteration.
+ */
+
+ SetChannelErrorStr(rcPtr->chan, msg_write_toomuch);
+ goto invalid;
+ }
+
+ *errorCodePtr = EOK;
+ stop:
+ Tcl_DecrRefCount(bufObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return written;
+ invalid:
+ *errorCodePtr = EINVAL;
+ error:
+ written = -1;
+ goto stop;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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, as it calls upon a script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static Tcl_WideInt
+ReflectSeekWide(
+ ClientData clientData,
+ Tcl_WideInt offset,
+ int seekMode,
+ int *errorCodePtr)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ Tcl_Obj *offObj, *baseObj;
+ Tcl_Obj *resObj; /* Result for 'seek' */
+ Tcl_WideInt newLoc;
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.seek.seekMode = seekMode;
+ p.seek.offset = offset;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedSeek, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rcPtr->chan, &p);
+ *errorCodePtr = EINVAL;
+ p.seek.offset = -1;
+ } else {
+ *errorCodePtr = EOK;
+ }
+
+ return p.seek.offset;
+ }
+#endif
+
+ /* ASSERT: rcPtr->method & FLAG(METH_SEEK) */
+
+ Tcl_Preserve(rcPtr);
+
+ offObj = Tcl_NewWideIntObj(offset);
+ baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" :
+ ((seekMode == SEEK_CUR) ? "current" : "end"), -1);
+ Tcl_IncrRefCount(offObj);
+ Tcl_IncrRefCount(baseObj);
+
+ if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK) {
+ Tcl_SetChannelError(rcPtr->chan, resObj);
+ goto invalid;
+ }
+
+ if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) {
+ Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp));
+ goto invalid;
+ }
+
+ if (newLoc < Tcl_LongAsWide(0)) {
+ SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart);
+ goto invalid;
+ }
+
+ *errorCodePtr = EOK;
+ stop:
+ Tcl_DecrRefCount(offObj);
+ Tcl_DecrRefCount(baseObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return newLoc;
+ invalid:
+ *errorCodePtr = EINVAL;
+ newLoc = -1;
+ goto stop;
+}
+
+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)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ Tcl_Obj *maskObj;
+
+ /* ASSERT rcPtr->methods & FLAG(METH_WATCH) */
+
+ /*
+ * We restrict the interest to what the channel can support. IOW there
+ * will never be write events for a channel which is not writable.
+ * Analoguously for read events and non-readable channels.
+ */
+
+ mask &= rcPtr->mode;
+
+ if (mask == rcPtr->interest) {
+ /*
+ * Same old, same old, why should we do something?
+ */
+
+ return;
+ }
+
+ rcPtr->interest = mask;
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.watch.mask = mask;
+ ForwardOpToOwnerThread(rcPtr, ForwardedWatch, &p);
+
+ /*
+ * Any failure from the forward is ignored. We have no place to put
+ * this.
+ */
+
+ return;
+ }
+#endif
+
+ Tcl_Preserve(rcPtr);
+
+ maskObj = DecodeEventMask(mask);
+ /* assert maskObj.refCount == 1 */
+ (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL);
+ Tcl_DecrRefCount(maskObj);
+
+ Tcl_Release(rcPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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)
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ Tcl_Obj *blockObj;
+ int errorNum; /* EINVAL or EOK (success). */
+ Tcl_Obj *resObj; /* Result data for 'blocking' */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.block.nonblocking = nonblocking;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedBlock, &p);
+
+ if (p.base.code != TCL_OK) {
+ PassReceivedError(rcPtr->chan, &p);
+ return EINVAL;
+ }
+
+ return EOK;
+ }
+#endif
+
+ blockObj = Tcl_NewBooleanObj(!nonblocking);
+ Tcl_IncrRefCount(blockObj);
+
+ Tcl_Preserve(rcPtr);
+
+ if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj) != TCL_OK) {
+ Tcl_SetChannelError(rcPtr->chan, resObj);
+ errorNum = EINVAL;
+ } else {
+ errorNum = EOK;
+ }
+
+ Tcl_DecrRefCount(blockObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+
+ Tcl_Release(rcPtr);
+ return errorNum;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectSetOption --
+ *
+ * This function is invoked to configure a channel option.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 */
+{
+ ReflectedChannel *rcPtr = (ReflectedChannel *) clientData;
+ Tcl_Obj *optionObj, *valueObj;
+ int result; /* Result code for 'configure' */
+ Tcl_Obj *resObj; /* Result data for 'configure' */
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ ForwardParam p;
+
+ p.setOpt.name = optionName;
+ p.setOpt.value = newValue;
+
+ ForwardOpToOwnerThread(rcPtr, ForwardedSetOpt, &p);
+
+ if (p.base.code != TCL_OK) {
+ Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1);
+
+ UnmarshallErrorResult(interp, err);
+ Tcl_DecrRefCount(err);
+ FreeReceivedError(&p);
+ }
+
+ return p.base.code;
+ }
+#endif
+ Tcl_Preserve(rcPtr);
+
+ optionObj = Tcl_NewStringObj(optionName, -1);
+ valueObj = Tcl_NewStringObj(newValue, -1);
+
+ Tcl_IncrRefCount(optionObj);
+ Tcl_IncrRefCount(valueObj);
+
+ result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj);
+ if (result != TCL_OK) {
+ UnmarshallErrorResult(interp, resObj);
+ }
+
+ Tcl_DecrRefCount(optionObj);
+ Tcl_DecrRefCount(valueObj);
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ReflectGetOption --
+ *
+ * This function is invoked to retrieve all or a channel option.
+ *
+ * Results:
+ * A standard Tcl result code.
+ *
+ * Side effects:
+ * Arbitrary, as it calls upon a Tcl script.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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 */
+{
+ /*
+ * This code is special. It has regular passing of Tcl result, and errors.
+ * The bypass functions are not required.
+ */
+
+ ReflectedChannel *rcPtr = (ReflectedChannel*) clientData;
+ Tcl_Obj *optionObj;
+ Tcl_Obj *resObj; /* Result data for 'configure' */
+ int listc, result = TCL_OK;
+ Tcl_Obj **listv;
+ const char *method;
+
+ /*
+ * Are we in the correct thread?
+ */
+
+#ifdef TCL_THREADS
+ if (rcPtr->thread != Tcl_GetCurrentThread()) {
+ int opcode;
+ ForwardParam p;
+
+ p.getOpt.name = optionName;
+ p.getOpt.value = dsPtr;
+
+ if (optionName == NULL) {
+ opcode = ForwardedGetOptAll;
+ } else {
+ opcode = ForwardedGetOpt;
+ }
+
+ ForwardOpToOwnerThread(rcPtr, opcode, &p);
+
+ if (p.base.code != TCL_OK) {
+ Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1);
+
+ UnmarshallErrorResult(interp, err);
+ Tcl_DecrRefCount(err);
+ FreeReceivedError(&p);
+ }
+
+ return p.base.code;
+ }
+#endif
+
+ if (optionName == NULL) {
+ /*
+ * Retrieve all options.
+ */
+
+ method = "cgetall";
+ optionObj = NULL;
+ } else {
+ /*
+ * Retrieve the value of one option.
+ */
+
+ method = "cget";
+ optionObj = Tcl_NewStringObj(optionName, -1);
+ Tcl_IncrRefCount(optionObj);
+ }
+
+ Tcl_Preserve(rcPtr);
+
+ if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj)!=TCL_OK) {
+ UnmarshallErrorResult(interp, resObj);
+ goto error;
+ }
+
+ /*
+ * The result has to go into the 'dsPtr' for propagation to the caller of
+ * the driver.
+ */
+
+ if (optionObj != NULL) {
+ Tcl_DStringAppend(dsPtr, TclGetString(resObj), -1);
+ goto ok;
+ }
+
+ /*
+ * Extract the list and append each item as element.
+ */
+
+ /*
+ * NOTE (4): If we extract the string rep we can assume a properly quoted
+ * string. Together with a separating space this way of simply appending
+ * the whole string rep might be faster. It also doesn't check if the
+ * result is a valid list. Nor that the list has an even number elements.
+ */
+
+ if (Tcl_ListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) {
+ goto error;
+ }
+
+ if ((listc % 2) == 1) {
+ /*
+ * Odd number of elements is wrong.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "Expected list with even number of "
+ "elements, got %d element%s instead", listc,
+ (listc == 1 ? "" : "s")));
+ goto error;
+ } else {
+ int len;
+ char *str = Tcl_GetStringFromObj(resObj, &len);
+
+ if (len) {
+ Tcl_DStringAppend(dsPtr, " ", 1);
+ Tcl_DStringAppend(dsPtr, str, len);
+ }
+ goto ok;
+ }
+
+ ok:
+ result = TCL_OK;
+ stop:
+ if (optionObj) {
+ Tcl_DecrRefCount(optionObj);
+ }
+ Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */
+ Tcl_Release(rcPtr);
+ return result;
+ error:
+ result = TCL_ERROR;
+ goto stop;
+}
+
+/*
+ * Helpers. =========================================================
+ */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodeEventMask --
+ *
+ * This function takes a list of event items and constructs the
+ * equivalent internal bitmask. The list must contain at least one
+ * element. Elements are "read", "write", or any unique abbreviation of
+ * them. Note that the bitmask is not changed if problems are
+ * encountered.
+ *
+ * Results:
+ * A standard Tcl error code. A bitmask where TCL_READABLE and/or
+ * TCL_WRITABLE can be set.
+ *
+ * Side effects:
+ * May shimmer 'obj' to a list representation. May place an error message
+ * into the interp result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+EncodeEventMask(
+ Tcl_Interp *interp,
+ const char *objName,
+ Tcl_Obj *obj,
+ int *mask)
+{
+ int events; /* Mask of events to post */
+ int listc; /* #elements in eventspec list */
+ Tcl_Obj **listv; /* Elements of eventspec list */
+ int evIndex; /* Id of event for an element of the eventspec
+ * list. */
+
+ if (Tcl_ListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ if (listc < 1) {
+ Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL);
+ return TCL_ERROR;
+ }
+
+ events = 0;
+ while (listc > 0) {
+ if (Tcl_GetIndexFromObj(interp, listv[listc-1], eventOptions,
+ objName, 0, &evIndex) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ switch (evIndex) {
+ case EVENT_READ:
+ events |= TCL_READABLE;
+ break;
+ case EVENT_WRITE:
+ events |= TCL_WRITABLE;
+ break;
+ }
+ listc --;
+ }
+
+ *mask = events;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ *----------------------------------------------------------------------
+ */
+
+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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * NewReflectedChannel --
+ *
+ * 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 ReflectedChannel *
+NewReflectedChannel(
+ Tcl_Interp *interp,
+ Tcl_Obj *cmdpfxObj,
+ int mode,
+ Tcl_Obj *handleObj)
+{
+ ReflectedChannel *rcPtr;
+ int i, listc;
+ Tcl_Obj **listv;
+
+ rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel));
+
+ /* rcPtr->chan: Assigned by caller. Dummy data here. */
+ /* rcPtr->methods: Assigned by caller. Dummy data here. */
+
+ rcPtr->chan = NULL;
+ rcPtr->methods = 0;
+ rcPtr->interp = interp;
+#ifdef TCL_THREADS
+ rcPtr->thread = Tcl_GetCurrentThread();
+#endif
+ rcPtr->mode = mode;
+ rcPtr->interest = 0; /* Initially no interest registered */
+
+ /*
+ * 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
+ */
+
+ rcPtr->argc = listc + 2;
+ rcPtr->argv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (listc+4));
+
+ /*
+ * Duplicate object references.
+ */
+
+ for (i=0; i<listc ; i++) {
+ Tcl_Obj *word = rcPtr->argv[i] = listv[i];
+
+ Tcl_IncrRefCount(word);
+ }
+
+ i++; /* Skip placeholder for method */
+
+ /*
+ * [Bug 1667990]: See [x] in FreeReflectedChannel for release
+ */
+
+ rcPtr->argv[i] = handleObj;
+ Tcl_IncrRefCount(handleObj);
+
+ /*
+ * The next two objects are kept empty, varying arguments.
+ */
+
+ /*
+ * Initialization complete.
+ */
+
+ return rcPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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(rcCounterMutex)
+ static unsigned long rcCounter = 0;
+ Tcl_Obj *resObj;
+
+ Tcl_MutexLock(&rcCounterMutex);
+ resObj = Tcl_ObjPrintf("rc%lu", rcCounter);
+ rcCounter++;
+ Tcl_MutexUnlock(&rcCounterMutex);
+
+ return resObj;
+}
+
+static void
+FreeReflectedChannel(
+ ReflectedChannel *rcPtr)
+{
+ Channel *chanPtr = (Channel *) rcPtr->chan;
+ int i, n;
+
+ if (chanPtr->typePtr != &tclRChannelType) {
+ /*
+ * Delete a cloned ChannelType structure.
+ */
+
+ ckfree((char*) chanPtr->typePtr);
+ }
+
+ n = rcPtr->argc - 2;
+ for (i=0; i<n; i++) {
+ Tcl_DecrRefCount(rcPtr->argv[i]);
+ }
+
+ /*
+ * [Bug 1667990]: See [x] in NewReflectedChannel for lock. n+1 = argc-1.
+ */
+
+ Tcl_DecrRefCount(rcPtr->argv[n+1]);
+
+ ckfree((char*) rcPtr->argv);
+ ckfree((char*) rcPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * 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.
+ *
+ * Contract:
+ * argOneObj.refCount >= 1 on entry and exit, if argOneObj != NULL
+ * argTwoObj.refCount >= 1 on entry and exit, if argTwoObj != NULL
+ * resObj.refCount in {0, 1, ...}
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+InvokeTclMethod(
+ ReflectedChannel *rcPtr,
+ 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 (!rcPtr->interp) {
+ /*
+ * The channel 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);
+ }
+
+ /*
+ * Not touching argOneObj, argTwoObj, they have not been used.
+ * See the contract as well.
+ */
+
+ return TCL_ERROR;
+ }
+
+ /*
+ * NOTE (5): Decide impl. issue: Cache objects with method names? Needs
+ * 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);
+ rcPtr->argv[rcPtr->argc - 2] = methObj;
+
+ /*
+ * Append the additional argument containing method specific details
+ * behind the channel id. If specified.
+ */
+
+ cmdc = rcPtr->argc;
+ if (argOneObj) {
+ rcPtr->argv[cmdc] = argOneObj;
+ cmdc++;
+ if (argTwoObj) {
+ rcPtr->argv[cmdc] = argTwoObj;
+ cmdc++;
+ }
+ }
+
+ /*
+ * And run the handler... This is done in auch a manner which leaves any
+ * existing state intact.
+ */
+
+ sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */);
+ Tcl_Preserve(rcPtr->interp);
+ result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->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(rcPtr->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, rcPtr->argv);
+ int cmdLen;
+ const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen);
+
+ Tcl_IncrRefCount(cmd);
+ Tcl_ResetResult(rcPtr->interp);
+ Tcl_SetObjResult(rcPtr->interp, Tcl_ObjPrintf(
+ "chan handler returned bad code: %d", result));
+ Tcl_LogCommandInfo(rcPtr->interp, cmdString, cmdString,
+ cmdLen);
+ Tcl_DecrRefCount(cmd);
+ result = TCL_ERROR;
+ }
+ Tcl_AppendObjToErrorInfo(rcPtr->interp, Tcl_ObjPrintf(
+ "\n (chan handler subcommand \"%s\")", method));
+ resObj = MarshallError(rcPtr->interp);
+ }
+ Tcl_IncrRefCount(resObj);
+ }
+ Tcl_RestoreInterpState(rcPtr->interp, sr);
+ Tcl_Release(rcPtr->interp);
+
+ /*
+ * Cleanup of the dynamic parts of the command.
+ *
+ * The detail objects survived the Tcl_EvalObjv without change because of
+ * the contract. Therefore there is no need to decrement the refcounts. Only
+ * the internal method object has to be disposed of.
+ */
+
+ Tcl_DecrRefCount(methObj);
+
+ /*
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ErrnoReturn --
+ *
+ * Checks a method error result if it returned an 'errno'.
+ *
+ * Results:
+ * The negative errno found in the error result, or 0.
+ *
+ * Side effects:
+ * None.
+ *
+ * Users:
+ * ReflectInput/Output(), to enable the signaling of EAGAIN
+ * on 0-sized short reads/writes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ErrnoReturn(ReflectedChannel *rcPtr, Tcl_Obj* resObj)
+{
+ int code;
+ Tcl_InterpState sr; /* State of handler interp */
+
+ if (!rcPtr->interp) {
+ return 0;
+ }
+
+ sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */);
+ UnmarshallErrorResult(rcPtr->interp, resObj);
+
+ resObj = Tcl_GetObjResult(rcPtr->interp);
+
+ if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) {
+ if (strcmp ("EAGAIN",Tcl_GetString(resObj)) == 0) {
+ code = - EAGAIN;
+ } else {
+ code = 0;
+ }
+ }
+
+ Tcl_RestoreInterpState(rcPtr->interp, sr);
+ return code;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetReflectedChannelMap --
+ *
+ * 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 ReflectedChannelMap *
+GetReflectedChannelMap(
+ Tcl_Interp *interp)
+{
+ ReflectedChannelMap* rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL);
+
+ if (rcmPtr == NULL) {
+ rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap));
+ Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
+ Tcl_SetAssocData(interp, RCMKEY,
+ (Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr);
+ }
+ return rcmPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteReflectedChannelMap --
+ *
+ * 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
+DeleteReflectedChannelMap(
+ ClientData clientData, /* The per-interpreter data structure. */
+ Tcl_Interp *interp) /* The interpreter being deleted. */
+{
+ ReflectedChannelMap* rcmPtr; /* The map */
+ Tcl_HashSearch hSearch; /* Search variable. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ ReflectedChannel* rcPtr;
+ Tcl_Channel chan;
+
+#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
+ * DeleteThreadReflectedChannelMap(), just restricted to the channels of
+ * this interp.
+ */
+
+ rcmPtr = clientData;
+ for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
+
+ chan = (Tcl_Channel) Tcl_GetHashValue (hPtr);
+ rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+ rcPtr->interp = NULL;
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+ Tcl_DeleteHashTable(&rcmPtr->map);
+ ckfree((char *) &rcmPtr->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(&rcForwardMutex);
+
+ 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
+ * ReflectedChannelMap, 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.
+ */
+
+ rcmPtr = GetThreadReflectedChannelMap();
+ for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_NextHashEntry(&hSearch)) {
+
+ chan = (Tcl_Channel) Tcl_GetHashValue (hPtr);
+ rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+ if (rcPtr->interp != interp) {
+ /* Ignore entries for other interpreters */
+ continue;
+ }
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ Tcl_MutexUnlock(&rcForwardMutex);
+#endif
+}
+
+#ifdef TCL_THREADS
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetThreadReflectedChannelMap --
+ *
+ * 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 ReflectedChannelMap *
+GetThreadReflectedChannelMap()
+{
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+ if (!tsdPtr->rcmPtr) {
+ tsdPtr->rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap));
+ Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
+ Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
+ }
+
+ return tsdPtr->rcmPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DeleteThreadReflectedChannelMap --
+ *
+ * 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
+ * DeleteReflectedChannelMap().
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Deletes the hash table of channels.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DeleteThreadReflectedChannelMap(
+ ClientData clientData) /* The per-thread data structure. */
+{
+ Tcl_HashSearch hSearch; /* Search variable. */
+ Tcl_HashEntry *hPtr; /* Search variable. */
+ Tcl_ThreadId self = Tcl_GetCurrentThread();
+
+ ReflectedChannelMap* rcmPtr; /* The map */
+ Tcl_Channel chan;
+ ReflectedChannel* rcPtr;
+ ForwardingResult *resultPtr;
+ ForwardingEvent *evPtr;
+ ForwardParam *paramPtr;
+
+ /*
+ * 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 DeleteReflectedChannelMap 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(&rcForwardMutex);
+
+ for (resultPtr = forwardList;
+ resultPtr != NULL;
+ resultPtr = resultPtr->nextPtr) {
+ 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
+ * ReflectedChannelMap, but on a per-thread basis, not per-interp. Go
+ * through the channels, remove all, mark them as dead.
+ */
+
+ rcmPtr = GetThreadReflectedChannelMap();
+ for (hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch);
+ hPtr != NULL;
+ hPtr = Tcl_FirstHashEntry(&rcmPtr->map, &hSearch)) {
+
+ chan = (Tcl_Channel) Tcl_GetHashValue (hPtr);
+ rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan);
+
+ rcPtr->interp = NULL;
+
+ Tcl_DeleteHashEntry(hPtr);
+ }
+
+ Tcl_MutexUnlock(&rcForwardMutex);
+}
+
+static void
+ForwardOpToOwnerThread(
+ ReflectedChannel *rcPtr, /* Channel instance */
+ ForwardedOperation op, /* Forwarded driver operation */
+ const VOID *param) /* Arguments */
+{
+ Tcl_ThreadId dst = rcPtr->thread;
+ ForwardingEvent *evPtr;
+ ForwardingResult *resultPtr;
+
+ /*
+ * We gather the lock early. This allows us to check the liveness of the
+ * channel without interference from DeleteThreadReflectedChannelMap().
+ */
+
+ Tcl_MutexLock(&rcForwardMutex);
+
+ if (rcPtr->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(&rcForwardMutex);
+ 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->rcPtr = rcPtr;
+ evPtr->param = (ForwardParam *) param;
+
+ resultPtr->src = Tcl_GetCurrentThread();
+ resultPtr->dst = dst;
+ resultPtr->dsti = rcPtr->interp;
+ 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. Exitus of the destination thread is handled
+ * by DeleteThreadReflectionChannelMap(), this is set up by
+ * GetThreadReflectedChannelMap(). 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, &rcForwardMutex, 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(&rcForwardMutex);
+ 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.
+ */
+
+ Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr);
+
+ 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;
+ ReflectedChannel *rcPtr = evPtr->rcPtr;
+ Tcl_Interp *interp = rcPtr->interp;
+ ForwardParam *paramPtr = evPtr->param;
+ Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */
+ ReflectedChannelMap* rcmPtr; /* Map of reflected channels with handlers in this interp */
+ Tcl_HashEntry* hPtr; /* Entry in the above map */
+
+ /*
+ * Ignore the event if no one is waiting for its result anymore.
+ */
+
+ if (!resultPtr) {
+ 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
+ * rcPtr->thread, which contains rcPtr->interp, the interp we have to
+ * call upon for the driver.
+ */
+
+ case ForwardedClose:
+ /*
+ * No parameters/results.
+ */
+
+ if (InvokeTclMethod(rcPtr, "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
+ *
+ * We remove the channel from both interpreter and thread maps before
+ * releasing the memory, to prevent future accesses (like by
+ * 'postevent') from finding and dereferencing a dangling pointer.
+ */
+
+ rcmPtr = GetReflectedChannelMap (interp);
+ hPtr = Tcl_FindHashEntry (&rcmPtr->map,
+ Tcl_GetChannelName (rcPtr->chan));
+ Tcl_DeleteHashEntry (hPtr);
+
+ rcmPtr = GetThreadReflectedChannelMap();
+ hPtr = Tcl_FindHashEntry (&rcmPtr->map,
+ Tcl_GetChannelName (rcPtr->chan));
+ Tcl_DeleteHashEntry (hPtr);
+
+ Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+ break;
+
+ case ForwardedInput: {
+ Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead);
+ Tcl_IncrRefCount(toReadObj);
+
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj)!=TCL_OK){
+ int code = ErrnoReturn (rcPtr, resObj);
+
+ if (code < 0) {
+ paramPtr->base.code = code;
+ } else {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+ paramPtr->input.toRead = -1;
+ } else {
+ /*
+ * Process a regular result.
+ */
+
+ int bytec; /* Number of returned bytes */
+ unsigned char *bytev; /* Array of returned bytes */
+
+ bytev = Tcl_GetByteArrayFromObj(resObj, &bytec);
+
+ if (paramPtr->input.toRead < bytec) {
+ ForwardSetStaticError(paramPtr, msg_read_toomuch);
+ paramPtr->input.toRead = -1;
+ } else {
+ if (bytec > 0) {
+ memcpy(paramPtr->input.buf, bytev, (size_t)bytec);
+ }
+ paramPtr->input.toRead = bytec;
+ }
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(toReadObj);
+ break;
+ }
+
+ case ForwardedOutput: {
+ Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *)
+ paramPtr->output.buf, paramPtr->output.toWrite);
+ Tcl_IncrRefCount(bufObj);
+
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj) != TCL_OK) {
+ int code = ErrnoReturn(rcPtr, resObj);
+
+ if (code < 0) {
+ paramPtr->base.code = code;
+ } else {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+ paramPtr->output.toWrite = -1;
+ } else {
+ /*
+ * Process a regular result.
+ */
+
+ int written;
+
+ if (Tcl_GetIntFromObj(interp, resObj, &written) != TCL_OK) {
+ ForwardSetObjError(paramPtr, MarshallError(interp));
+ paramPtr->output.toWrite = -1;
+ } else if (written==0 || paramPtr->output.toWrite<written) {
+ ForwardSetStaticError(paramPtr, msg_write_toomuch);
+ paramPtr->output.toWrite = -1;
+ } else {
+ paramPtr->output.toWrite = written;
+ }
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(bufObj);
+ break;
+ }
+
+ case ForwardedSeek: {
+ Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset);
+ Tcl_Obj *baseObj = Tcl_NewStringObj(
+ (paramPtr->seek.seekMode==SEEK_SET) ? "start" :
+ (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end", -1);
+
+ Tcl_IncrRefCount(offObj);
+ Tcl_IncrRefCount(baseObj);
+
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj)!=TCL_OK){
+ ForwardSetObjError(paramPtr, resObj);
+ paramPtr->seek.offset = -1;
+ } else {
+ /*
+ * Process a regular result. If the type is wrong this may change
+ * into an error.
+ */
+
+ Tcl_WideInt newLoc;
+
+ if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) {
+ if (newLoc < Tcl_LongAsWide(0)) {
+ ForwardSetStaticError(paramPtr, msg_seek_beforestart);
+ paramPtr->seek.offset = -1;
+ } else {
+ paramPtr->seek.offset = newLoc;
+ }
+ } else {
+ ForwardSetObjError(paramPtr, MarshallError(interp));
+ paramPtr->seek.offset = -1;
+ }
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(offObj);
+ Tcl_DecrRefCount(baseObj);
+ break;
+ }
+
+ case ForwardedWatch: {
+ Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask);
+ /* assert maskObj.refCount == 1 */
+
+ Tcl_Preserve(rcPtr);
+ (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL);
+ Tcl_DecrRefCount(maskObj);
+ Tcl_Release(rcPtr);
+ break;
+ }
+
+ case ForwardedBlock: {
+ Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking);
+ Tcl_IncrRefCount(blockObj);
+
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL,
+ &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(blockObj);
+ break;
+ }
+
+ case ForwardedSetOpt: {
+ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1);
+ Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1);
+
+ Tcl_IncrRefCount(optionObj);
+ Tcl_IncrRefCount(valueObj);
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj,
+ &resObj) != TCL_OK) {
+ ForwardSetObjError(paramPtr, resObj);
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(optionObj);
+ Tcl_DecrRefCount(valueObj);
+ break;
+ }
+
+ case ForwardedGetOpt: {
+ /*
+ * Retrieve the value of one option.
+ */
+
+ Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1);
+ Tcl_IncrRefCount(optionObj);
+
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj)!=TCL_OK){
+ ForwardSetObjError(paramPtr, resObj);
+ } else {
+ Tcl_DStringAppend(paramPtr->getOpt.value,
+ TclGetString(resObj), -1);
+ }
+ Tcl_Release(rcPtr);
+ Tcl_DecrRefCount(optionObj);
+ break;
+ }
+
+ case ForwardedGetOptAll:
+ /*
+ * Retrieve all options.
+ */
+
+ Tcl_Preserve(rcPtr);
+ if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj) != TCL_OK){
+ ForwardSetObjError(paramPtr, resObj);
+ } else {
+ /*
+ * Extract list, validate that it is a list, and #elements. See
+ * NOTE (4) as well.
+ */
+
+ int listc;
+ Tcl_Obj **listv;
+
+ if (Tcl_ListObjGetElements(interp, resObj, &listc,
+ &listv) != TCL_OK) {
+ ForwardSetObjError(paramPtr, MarshallError(interp));
+ } else if ((listc % 2) == 1) {
+ /*
+ * Odd number of elements is wrong. [x].
+ */
+
+ char *buf = ckalloc(200);
+ sprintf(buf,
+ "{Expected list with even number of elements, got %d %s instead}",
+ listc, (listc == 1 ? "element" : "elements"));
+
+ ForwardSetDynamicError(paramPtr, buf);
+ } else {
+ int len;
+ const char *str = Tcl_GetStringFromObj(resObj, &len);
+
+ if (len) {
+ Tcl_DStringAppend(paramPtr->getOpt.value, " ", 1);
+ Tcl_DStringAppend(paramPtr->getOpt.value, str, len);
+ }
+ }
+ }
+ Tcl_Release(rcPtr);
+ 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(&rcForwardMutex);
+ resultPtr->result = TCL_OK;
+ Tcl_ConditionNotify(&resultPtr->done);
+ Tcl_MutexUnlock(&rcForwardMutex);
+ }
+
+ 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(&rcForwardMutex);
+
+ 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(&rcForwardMutex);
+
+ /*
+ * 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
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
+ * End:
+ */