summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog21
-rw-r--r--generic/tclIOCmd.c4
-rw-r--r--generic/tclIORTrans.c3345
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclVar.c4
-rw-r--r--tests/chan.test4
-rw-r--r--tests/ioCmd.test6
-rw-r--r--tests/ioTrans.test1463
-rw-r--r--unix/Makefile.in8
-rw-r--r--win/Makefile.in3
-rw-r--r--win/makefile.vc3
11 files changed, 4855 insertions, 12 deletions
diff --git a/ChangeLog b/ChangeLog
index a84cd49..cb4114c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,24 @@
+2008-06-06 Andreas Kupries <andreask@activestate.com>
+
+ TIP #230 IMPLEMENTATION
+
+ * generic/tclIOCmd.c: Integration of transform commands into 'chan' ensemble.
+ * generic/tclInt.h: Definitions of the transform commands.
+ * generic/tclIORTrans.c: Implementation of the reflection transforms.
+ * tests/chan.test: Tests updated for new sub-commands of 'chan'.
+ * tests/ioCmd.test: Tests updated for new sub-commands of 'chan'.
+ * tests/ioTrans.test: Whole new set of tests for the reflection transform.
+ * unix/Makefile.in: Integration of new files into build rules.
+ * win/Makefile.in: Integration of new files into build rules.
+ * win/makefile.vc: Integration of new files into build rules.
+
+ NOTE: The file 'tclIORTrans.c' has a lot of code in common with
+ the file 'tclIORChan.c', as that made it much easier to
+ develop the reference implementation as a separate
+ module. Now that the transforms have been committed the one
+ thing left to do is to go over both modules and see which of
+ the common parts we can factor out and share.
+
2008-06-04 Pat Thoyts <patthoyts@users.sourceforge.net>
* generic/tclBinary.c: TIP #317 implementation
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index be34dc1..131b905 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOCmd.c,v 1.53 2008/04/10 20:58:59 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclIOCmd.c,v 1.54 2008/06/06 19:46:36 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1838,7 +1838,9 @@ TclInitChanCmd(
{"flush", Tcl_FlushObjCmd},
{"gets", Tcl_GetsObjCmd},
{"pending", ChanPendingObjCmd}, /* TIP #287 */
+ {"pop", TclChanPopObjCmd}, /* TIP #230 */
{"postevent", TclChanPostEventObjCmd}, /* TIP #219 */
+ {"push", TclChanPushObjCmd}, /* TIP #230 */
{"puts", Tcl_PutsObjCmd},
{"read", Tcl_ReadObjCmd},
{"seek", Tcl_SeekObjCmd},
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
new file mode 100644
index 0000000..908c480
--- /dev/null
+++ b/generic/tclIORTrans.c
@@ -0,0 +1,3345 @@
+/*
+ * 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.1 2008/06/06 19:46:37 andreas_kupries 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)
+
+/*
+ * 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, (unsigned char*) 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 that we want (full EOF
+ * or temporary 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;
+ }
+ 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, 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, (unsigned char*) 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 = (unsigned char*) 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 = (unsigned char*) 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 = (unsigned char*) Tcl_Alloc (r->allocated);
+ } else {
+ r->allocated += toWrite + RB_INCREMENT;
+ r->buf = (unsigned char*) 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 = 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, 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 = 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, 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:
+ */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 3ec57b4..3fe993d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.369 2008/05/31 11:42:14 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.370 2008/06/06 19:46:37 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -2744,6 +2744,10 @@ MODULE_SCOPE int TclChanCreateObjCmd(ClientData clientData,
MODULE_SCOPE int TclChanPostEventObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPopObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
MODULE_SCOPE void TclClockInit(Tcl_Interp *interp);
MODULE_SCOPE int TclClockOldscanObjCmd(
ClientData clientData, Tcl_Interp *interp,
diff --git a/generic/tclVar.c b/generic/tclVar.c
index b7bdcaf..6279064 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -16,7 +16,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclVar.c,v 1.162 2008/05/23 21:05:13 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.163 2008/06/06 19:46:37 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -67,8 +67,10 @@ VarHashCreateVar(
#define VarHashFindVar(tablePtr, key) \
VarHashCreateVar((tablePtr), (key), NULL)
+
#define VarHashInvalidateEntry(varPtr) \
((varPtr)->flags |= VAR_DEAD_HASH)
+
#define VarHashDeleteEntry(varPtr) \
Tcl_DeleteHashEntry(&(((VarInHash *) varPtr)->entry))
diff --git a/tests/chan.test b/tests/chan.test
index eb09fd7..72eccbb 100644
--- a/tests/chan.test
+++ b/tests/chan.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: chan.test,v 1.11 2007/12/13 15:26:04 dgp Exp $
+# RCS: @(#) $Id: chan.test,v 1.12 2008/06/06 19:46:38 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -24,7 +24,7 @@ test chan-1.1 {chan command general syntax} -body {
} -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\""
test chan-1.2 {chan command general syntax} -body {
chan FOOBAR
-} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate"
+} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate"
test chan-2.1 {chan command: blocked subcommand} -body {
chan blocked foo bar
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 82c9645..06116d3 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -13,7 +13,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: ioCmd.test,v 1.42 2008/04/24 18:51:01 andreas_kupries Exp $
+# RCS: @(#) $Id: ioCmd.test,v 1.43 2008/06/06 19:46:38 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -641,7 +641,7 @@ test iocmd-20.0 {chan, wrong#args} {
test iocmd-20.1 {chan, unknown method} {
catch {chan foo} msg
set msg
-} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, postevent, puts, read, seek, tell, or truncate}
+} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate}
# --- --- --- --------- --------- ---------
# chan create, and method "initalize"
@@ -1894,7 +1894,7 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
proc foo {args} {
oninit; onfinal; track;
# destroy interpreter during channel access
- # Actually not possible for an interp to destory itself.
+ # Actually not possible for an interp to destroy itself.
interp delete {}
return}
set chan [chan create {r w} foo]
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
new file mode 100644
index 0000000..070aab1
--- /dev/null
+++ b/tests/ioTrans.test
@@ -0,0 +1,1463 @@
+# -*- tcl -*-
+# Functionality covered: operation of the reflected transformation
+#
+# This file contains a collection of tests for one or more of the Tcl
+# built-in commands. Sourcing this file into Tcl runs the tests and
+# generates output for errors. No output means no errors were found.
+#
+# Copyright (c) 2007 Andreas Kupries <andreask@activestate.com>
+# <akupries@shaw.ca>
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: ioTrans.test,v 1.1 2008/06/06 19:46:42 andreas_kupries Exp $
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+# Custom constraints used in this file
+testConstraint testchannel [llength [info commands testchannel]]
+testConstraint testthread [llength [info commands testthread]]
+
+# testchannel cut|splice Both needed to test the reflection in threads.
+# testthread send
+
+#----------------------------------------------------------------------
+
+# ### ### ### ######### ######### #########
+## Testing the reflected transformation.
+
+# Helper commands to record the arguments to handler methods. Stored
+# in a script so that the tests needing this code do not need their
+# own copy but can access this variable.
+
+set helperscript {
+ if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+ }
+
+ proc note {item} {global res; lappend res $item; return}
+ proc track {} {upvar args item; note $item; return}
+ proc notes {items} {foreach i $items {note $i}}
+
+ # Use to prevent *'s in pattern to match beyond the expected end
+ # of the recording.
+ proc endnote {} {note |}
+
+ # This forces the return options to be in the order that the test
+ # expects!
+ proc noteOpts opts {global res; lappend res [dict merge {
+ -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
+ } $opts]; return}
+
+ # Helper command, canned result for 'initialize' method. Gets the
+ # optional methods as arguments. Use return features to post the
+ # result higher up.
+
+ proc init {args} {
+ lappend args initialize finalize read write
+ return -code return $args
+ }
+ proc oninit {args} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "initialize"} {return}
+ lappend args initialize finalize read write
+ return -code return $args
+ }
+ proc onfinal {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "finalize"} {return}
+ return -code return ""
+ }
+ proc onread {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "read"} {return}
+ return -code return "@"
+ }
+ proc ondrain {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "drain"} {return}
+ return -code return "<>"
+ }
+ proc onclear {} {
+ upvar args hargs
+ if {[lindex $hargs 0] ne "clear"} {return}
+ return -code return ""
+ }
+
+ proc tempchan {{mode r+}} {
+ global tempchan
+ set tempchan [open [makeFile {test data} tempchanfile] $mode]
+ return $tempchan
+ }
+
+ proc tempdone {} {
+ global tempchan
+ catch {close $tempchan}
+ removeFile tempchanfile
+ return
+ }
+
+ proc tempview {} { viewFile tempchanfile }
+}
+
+# Set everything up in the main thread.
+eval $helperscript
+
+#puts <<[file channels]>>
+
+# ### ### ### ######### ######### #########
+
+test iortrans-1.0 {chan, wrong#args} {
+ catch {chan} msg
+ set msg
+} {wrong # args: should be "chan subcommand ?argument ...?"}
+test iortrans-1.1 {chan, unknown method} {
+ catch {chan foo} msg
+ set msg
+} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate}
+
+# --- --- --- --------- --------- ---------
+# chan push, and method "initalize"
+
+test iortrans-2.0 {chan push, wrong#args, not enough} {
+ catch {chan push} msg
+ set msg
+} {wrong # args: should be "chan push channel cmdprefix"}
+test iortrans-2.1 {chan push, wrong#args, too many} {
+ catch {chan push a b c} msg
+ set msg
+} {wrong # args: should be "chan push channel cmdprefix"}
+test iortrans-2.2 {chan push, invalid channel} {
+ proc foo {} {}
+ catch {chan push {} foo} msg
+ rename foo {}
+ set msg
+} {can not find channel named ""}
+test iortrans-2.3 {chan push, bad handler, not a list} {
+ catch {chan push [tempchan] "foo \{"} msg
+ tempdone
+ set msg
+} {unmatched open brace in list}
+test iortrans-2.4 {chan push, bad handler, not a command} {
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ set msg
+} {invalid command name "foo"}
+test iortrans-2.5 {chan push, initialize failed, bad signature} {
+ proc foo {} {}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} {wrong # args: should be "foo"}
+test iortrans-2.6 {chan push, initialize failed, bad signature} {
+ proc foo {} {}
+ catch {chan push [tempchan] ::foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} {wrong # args: should be "::foo"}
+test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body {
+ proc foo {args} {return "\{"}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set ::errorInfo
+} -match glob -result {chan handler "foo initialize" returned non-list: *}
+test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body {
+ proc foo {args} {return \{\{\}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {chan handler "foo initialize" returned non-list: *}
+test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body {
+ proc foo {args} {}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*all required methods*}
+test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body {
+ proc foo {args} {return 1}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*bad method "1": must be *}
+test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body {
+ proc foo {args} {return {a b c}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*bad method "c": must be *}
+test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body {
+ # Required: initialize, and finalize.
+ proc foo {args} {return {initialize}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*all required methods*}
+test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body {
+ proc foo {args} {return {initialize finalize BOGUS}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write}
+test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body {
+ proc foo {args} {return {initialize finalize}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*makes the channel inacessible}
+# iortrans-2.15 event/watch methods elimimated, removed these tests.
+# iortrans-2.16
+test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body {
+ proc foo {args} {return {initialize finalize drain write}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*supports "drain" but not "read"}
+test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body {
+ proc foo {args} {return {initialize finalize flush read}}
+ catch {chan push [tempchan] foo} msg
+ tempdone
+ rename foo {}
+ set msg
+} -match glob -result {*supports "flush" but not "write"}
+test iortrans-2.19 {chan push, initialize ok, creates channel} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ if {[lindex $args 0] ne "initialize"} {return}
+ return {initialize finalize drain flush read write}
+ }
+ set res {}
+ lappend res [file channel rt*]
+ lappend res [chan push [tempchan] foo]
+ lappend res [close [lindex $res end]]
+ lappend res [file channel rt*]
+ tempdone
+ rename foo {}
+ set res
+} -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}}
+test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body {
+ proc foo {args} {
+ global res
+ lappend res $args
+ return {}
+ }
+ set res {}
+ lappend res [file channel rt*]
+ lappend res [catch {chan push [tempchan] foo} msg]
+ lappend res $msg
+ lappend res [file channel rt*]
+ tempdone
+ rename foo {}
+ set res
+} -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}}
+
+# --- --- --- --------- --------- ---------
+# method finalize (via close)
+
+# General note: file channels rt* finds the transform channel, however
+# the name reported will be that of the underlying base driver, fileXX
+# here. This actually allows us to see if the whole channel is gone,
+# or only the transformation, but not the base.
+
+test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return}
+ note [set c [chan push [tempchan] foo]]
+ rename foo {}
+ note [file channels file*]
+ note [file channels rt*]
+ note [catch {close $c} msg]; note $msg
+ note [file channels file*]
+ note [file channels rt*]
+ set res
+} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}}
+test iortrans-3.2 {chan finalize, for close} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return {}}
+ note [set c [chan push [tempchan] foo]]
+ close $c
+ # Close deleted the channel.
+ note [file channels rt*]
+ # Channel destruction does not kill handler command!
+ note [info command foo]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
+test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code error 5}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ # Channel is gone despite error.
+ note [file channels rt*]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
+test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; error FOO}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg; note $::errorInfo
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO
+*"close $c"}}
+test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return SOMETHING}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
+test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 3}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 4}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg]; note $msg
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
+test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup {
+ set res {}
+} -body {
+ proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ note [catch {close $c} msg opt]; note $msg; noteOpts $opt
+ return $res
+} -cleanup {
+ rename foo {}
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}}
+
+# --- === *** ###########################
+# method read (via read)
+
+test iortrans-4.1 {chan read, transform call and return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return snarf
+ }
+ set c [chan push [tempchan] foo]
+ note [read $c 10]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} snarf}
+test iortrans-4.2 {chan read, for non-readable channel} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track; note MUST_NOT_HAPPEN
+ }
+ set c [chan push [tempchan w] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {1 {channel "file*" wasn't opened for reading}}
+test iortrans-4.3 {chan read, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 BOOM!}
+test iortrans-4.4 {chan read, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.5 {chan read, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.6 {chan read, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg]; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*}
+test iortrans-4.7 {chan read, level is squashed} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}}
+
+
+# --- === *** ###########################
+# method write (via puts)
+
+test iortrans-5.1 {chan write, regular write} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return transformresult }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarf; flush $c
+ close $c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarf} transformresult}
+test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return {} }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarfsnarfsnarf; flush $c
+ close $c
+ note [tempview];# This has to show the original data, as nothing was written
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} {test data}}
+test iortrans-5.3 {chan write, failed write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error FAIL!}
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarfsnarfsnarf
+ note [catch {flush $c} msg] ; note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
+test iortrans-5.4 {chan write, non-writable channel} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
+ set c [chan push [tempchan r] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg
+ close $c
+ tempdone
+ rename foo {}
+ set res
+} -result {1 {channel "file*" wasn't opened for writing}}
+test iortrans-5.5 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans-5.6 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; error BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
+test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
+test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
+ note $msg
+ noteOpts $opt
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}}
+
+# --- === *** ###########################
+# method limit?, drain (via read)
+
+test iortrans-6.1 {chan read, read limits} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit limit?; onfinal; track ; onread
+ return 6
+ }
+ set c [chan push [tempchan] foo]
+ note [read $c 10]
+ tempdone
+ rename foo {}
+ set res
+} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
+}} {limit? rt*} @@}
+test iortrans-6.2 {chan read, read transform drain on eof} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit drain; onfinal; track ; onread ; ondrain
+ return
+ }
+ set c [chan push [tempchan] foo]
+ note [read $c]
+ note [close $c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} {drain rt*} @<> {}}
+
+# --- === *** ###########################
+# method clear (via puts, seek)
+
+test iortrans-7.1 {chan write, write clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track ; onclear
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ puts -nonewline $c snarf; flush $c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*} {write rt* snarf}}
+test iortrans-7.2 {seek clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return
+ }
+ set c [chan push [tempchan] foo]
+ seek $c 2
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}}
+test iortrans-7.3 {clear, any result is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return -code error "X"
+ }
+ set c [chan push [tempchan] foo]
+ seek $c 2
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}}
+
+# --- === *** ###########################
+# method flush (via seek, close)
+
+test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; onfinal; track
+ return X
+ }
+ set c [chan push [tempchan] foo]
+ # Flush, no writing
+ seek $c 2
+ # The close flushes again, this modifies the file!
+ note | ; note [close $c] ; note |
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} | {flush rt*} {} | {teXt data}}
+
+test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; track ; onfinal
+ return .flushed.
+ }
+ set c [chan push [tempchan] foo]
+ close $c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} {finalize rt*} .flushed.}
+
+
+# --- === *** ###########################
+# method watch - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# method event - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# 'Pull the rug' tests. Create channel in a interpreter A, move to
+# other interpreter B, destroy the origin interpreter (A) before or
+# during access from B. Must not crash, must return proper errors.
+
+test iortrans-11.0 {origin interpreter of moved transform gone} -match glob -body {
+
+ set ida [interp create];#puts <<$ida>>
+ set idb [interp create];#puts <<$idb>>
+
+ # Magic to get the test* commands in the slaves
+ load {} Tcltest $ida
+ load {} Tcltest $idb
+
+ # Set up channel and transform in interpreter
+ interp eval $ida $helperscript
+ set chan [interp eval $ida {
+ proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd interpreter, transform goes with it.
+ interp eval $ida [list testchannel cut $chan]
+ interp eval $idb [list testchannel splice $chan]
+
+ # Kill origin interpreter, then access channel from 2nd interpreter.
+ interp delete $ida
+
+ set res {}
+ lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg
+ lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg
+ lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg
+ lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg
+ lappend res [catch {interp eval $idb [list close $chan]} msg] $msg
+ #lappend res [interp eval $ida {set res}]
+ # actions: clear|write|clear|write|clear|flush|limit?|drain|flush
+ set res
+ # The 'tell' is ok, as it passed through the transform to the base
+ # channel without invoking the transform handler.
+} -constraints {testchannel} \
+ -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -match glob -body {
+
+ set ida [interp create];#puts <<$ida>>
+ set idb [interp create];#puts <<$idb>>
+
+ # Magic to get the test* commands in the slaves
+ load {} Tcltest $ida
+ load {} Tcltest $idb
+
+ # Set up channel in thread
+ set chan [interp eval $ida $helperscript]
+ set chan [interp eval $ida {
+ proc foo {args} {
+ oninit clear drain flush limit? read write; onfinal; track;
+ # destroy interpreter during channel access
+ # Actually not possible for an interp to destroy itself.
+ interp delete {}
+ return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ interp eval $ida [list testchannel cut $chan]
+ interp eval $idb [list testchannel splice $chan]
+
+ # Run access from interpreter B, this will give us a synchronous
+ # response.
+
+ interp eval $idb [list set chan $chan]
+ interp eval $idb [list set mid $tcltest::mainThread]
+ set res [interp eval $idb {
+ # wait a bit, give the main thread the time to start its event
+ # loop to wait for the response from B
+ after 2000
+ catch { puts $chan shoo } res
+ set res
+ }]
+ set res
+} -constraints {testchannel impossible} \
+ -result {Owner lost}
+
+# ### ### ### ######### ######### #########
+## Same tests as above, but exercising the code forwarding and
+## receiving driver operations to the originator thread.
+
+# -*- tcl -*-
+# ### ### ### ######### ######### #########
+## Testing the reflected channel (Thread forwarding).
+#
+## The id numbers refer to the original test without thread
+## forwarding, and gaps due to tests not applicable to forwarding are
+## left to keep this association.
+
+# Duplicate of code in "thread.test", and "ioCmd.test". Find a better
+# way of doing this without duplication. Maybe placement into a proc
+# which transforms to nop after the first call, and placement of its
+# defintion in a central location.
+
+if {[testConstraint testthread]} {
+ testthread errorproc ThreadError
+
+ proc ThreadError {id info} {
+ global threadError
+ set threadError $info
+ }
+ proc ThreadNullError {id info} {
+ # ignore
+ }
+}
+
+# ### ### ### ######### ######### #########
+## Helper command. Runs a script in a separate thread and returns the
+## result. A channel is transfered into the thread as well, and a list
+## of configuation variables
+
+proc inthread {chan script args} {
+ # Test thread.
+
+ set tid [testthread create]
+
+ # Init thread configuration.
+ # - Listed variables
+ # - Id of main thread
+ # - A number of helper commands
+
+ foreach v $args {
+ upvar 1 $v x
+ testthread send $tid [list set $v $x]
+ }
+ testthread send $tid [list set mid $tcltest::mainThread]
+ testthread send $tid {
+ proc note {item} {global notes; lappend notes $item}
+ proc notes {} {global notes; return $notes}
+ proc noteOpts opts {global notes; lappend notes [dict merge {
+ -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
+ } $opts]}
+ }
+ testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
+
+ # Transfer channel (cut/splice aka detach/attach)
+
+ testchannel cut $chan
+ testthread send $tid [list testchannel splice $chan]
+
+ # Run test script, also run local event loop!
+ # The local event loop waits for the result to come back.
+ # It is also necessary for the execution of forwarded channel
+ # operations.
+
+ set ::tres ""
+ testthread send -async $tid {
+ after 500
+ catch {s} res; # This runs the script, 's' was defined at (*)
+ testthread send -async $mid [list set ::tres $res]
+ }
+ vwait ::tres
+ # Remove test thread, and return the captured result.
+
+ tcltest::threadReap
+ return $::tres
+}
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+
+test iortrans.tf-3.2 {chan finalize, for close} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return {}}
+ note [set c [chan push [tempchan] foo]]
+ note [inthread $c {
+ close $c
+ # Close the deleted the channel.
+ file channels rt*
+ } c]
+ # Channel destruction does not kill handler command!
+ note [info command foo]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
+test iortrans.tf-3.3 {chan finalize, for close, error, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code error 5}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ # Channel is gone despite error.
+ note [file channels rt*]
+ notes
+ } c]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
+test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; error FOO}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO}
+test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return SOMETHING}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
+test iortrans.tf-3.6 {chan finalize, for close, break, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 3}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
+ -constraints {testchannel testthread}
+
+
+test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 4}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg]; note $msg
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -match glob -body {
+ set res {}
+ proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
+ note [set c [chan push [tempchan] foo]]
+ notes [inthread $c {
+ note [catch {close $c} msg opt]; note $msg; noteOpts $opt
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method read
+
+test iortrans.tf-4.1 {chan read, transform call and return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return snarf
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [read $c 10]
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{read rt* {test data
+}} snarf}
+
+test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track; note MUST_NOT_HAPPEN
+ }
+ set c [chan push [tempchan w] foo]
+ notes [inthread $c {
+ note [catch {[read $c 2]} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}}
+test iortrans.tf-4.3 {chan read, error return} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code error BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 BOOM!} \
+ -constraints {testchannel testthread}
+test iortrans.tf-4.4 {chan read, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code break BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code continue BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg]; note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code*} \
+ -constraints {testchannel testthread}
+
+test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit; onfinal; track
+ return -level 55 -code 777 BOOM!
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \
+ -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method write
+
+test iortrans.tf-5.1 {chan write, regular write} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return transformresult }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarf; flush $c
+ close $c
+ } c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult}
+test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body {
+ set res {}
+ proc foo {args} { oninit; onfinal; track ; return {} }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarfsnarfsnarf; flush $c
+ close $c
+ } c
+ note [tempview];# This has to show the original data, as nothing was written
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{write rt* snarfsnarfsnarf} {test data}}
+test iortrans.tf-5.3 {chan write, failed write} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error FAIL!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ puts -nonewline $c snarfsnarfsnarf
+ note [catch {flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
+test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
+ set c [chan push [tempchan r] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -constraints {testchannel testthread} \
+ -result {1 {channel "file*" wasn't opened for writing}}
+test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; error BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \
+ -constraints {testchannel testthread}
+
+
+test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]
+ note $msg
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \
+ -constraints {testchannel testthread}
+test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt]
+ note $msg
+ noteOpts $opt
+ close $c
+ notes
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
+ -constraints {testchannel testthread}
+
+
+# --- === *** ###########################
+# method limit?, drain (via read)
+
+test iortrans.tf-6.1 {chan read, read limits} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit limit?; onfinal; track ; onread
+ return 6
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [read $c 10]
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata
+}} {limit? rt*} @@} -constraints {testchannel testthread}
+test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit drain; onfinal; track ; onread ; ondrain
+ return
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ note [read $c]
+ note [close $c]
+ } c]
+ tempdone
+ rename foo {}
+ set res
+} -result {{read rt* {test data
+}} {drain rt*} @<> {}} -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method clear (via puts, seek)
+
+test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track ; onclear
+ return transformresult
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ puts -nonewline $c snarf; flush $c
+ close $c
+ } c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread}
+test iortrans.tf-7.2 {seek clears read buffers} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ seek $c 2
+ close $c
+ } c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}} -constraints {testchannel testthread}
+test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit clear; onfinal; track
+ return -code error "X"
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ seek $c 2
+ close $c
+ } c
+ tempdone
+ rename foo {}
+ set res
+} -result {{clear rt*}} -constraints {testchannel testthread}
+
+# --- === *** ###########################
+# method flush (via seek, close)
+
+test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; onfinal; track
+ return X
+ }
+ set c [chan push [tempchan] foo]
+ notes [inthread $c {
+ # Flush, no writing
+ seek $c 2
+ # The close flushes again, this modifies the file!
+ note | ; note [close $c] ; note |
+ # NOTE: The flush generated by the close is recorded
+ # immediately, the other note's here are defered until after
+ # the thread is done. This changes the order of the result a
+ # bit from the non-threaded case (The first | moves one to the
+ # right). This is an artifact of the 'inthread' framework, not
+ # of the transformation itself.
+ notes
+ } c]
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread}
+
+test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body {
+ set res {}
+ proc foo {args} {
+ oninit flush; track ; onfinal
+ return .flushed.
+ }
+ set c [chan push [tempchan] foo]
+ inthread $c {
+ close $c
+ } c
+ note [tempview]
+ tempdone
+ rename foo {}
+ set res
+} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread}
+
+
+# --- === *** ###########################
+# method watch - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# method event - removed from TIP (rev 1.12+)
+
+# --- === *** ###########################
+# 'Pull the rug' tests. Create channel in a thread A, move to other
+# thread B, destroy the origin thread (A) before or during access from
+# B. Must not crash, must return proper errors.
+
+test iortrans.tf-11.0 {origin thread of moved transform gone} -match glob -body {
+
+ #puts <<$tcltest::mainThread>>main
+ set tida [testthread create];#puts <<$tida>>
+ set tidb [testthread create];#puts <<$tidb>>
+
+ # Set up channel in thread
+ testthread send $tida $helperscript
+ set chan [testthread send $tida {
+ proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ testthread send $tida [list testchannel cut $chan]
+ testthread send $tidb [list testchannel splice $chan]
+
+ # Kill origin thread, then access channel from 2nd thread.
+ testthread send -async $tida {testthread exit}
+ after 100
+
+ set res {}
+ lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg
+ lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg
+ lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg
+ lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg
+ lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg
+ tcltest::threadReap
+ set res
+ # The 'tell' is ok, as it passed through the transform to the base
+ # channel without invoking the transform handler.
+
+} -constraints {testchannel testthread} \
+ -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body {
+
+ #puts <<$tcltest::mainThread>>main
+ set tida [testthread create];#puts <<$tida>>
+ set tidb [testthread create];#puts <<$tidb>>
+
+ # Set up channel in thread
+ set chan [testthread send $tida $helperscript]
+ set chan [testthread send $tida {
+ proc foo {args} {
+ oninit clear drain flush limit? read write; onfinal; track;
+ # destroy thread during channel access
+ testthread exit
+ return}
+ set chan [chan push [tempchan] foo]
+ fconfigure $chan -buffering none
+ set chan
+ }]
+
+ # Move channel to 2nd thread, transform goes with it.
+ testthread send $tida [list testchannel cut $chan]
+ testthread send $tidb [list testchannel splice $chan]
+
+ # Run access from thread B, wait for response from A (A is not
+ # using event loop at this point, so the event pile up in the
+ # queue.
+
+ testthread send $tidb [list set chan $chan]
+ testthread send $tidb [list set mid $tcltest::mainThread]
+ testthread send -async $tidb {
+ # wait a bit, give the main thread the time to start its event
+ # loop to wait for the response from B
+ after 2000
+ catch { puts $chan shoo } res
+ testthread send -async $mid [list set ::res $res]
+ }
+ vwait ::res
+
+ tcltest::threadReap
+ set res
+} -constraints {testchannel testthread} \
+ -result {Owner lost}
+
+# ### ### ### ######### ######### #########
+
+# ### ### ### ######### ######### #########
+
+rename track {}
+cleanupTests
+return
diff --git a/unix/Makefile.in b/unix/Makefile.in
index d7d6f82..bf35876 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -4,7 +4,7 @@
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.236 2008/06/01 00:02:05 dkf Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.237 2008/06/06 19:46:42 andreas_kupries Exp $
VERSION = @TCL_VERSION@
MAJOR_VERSION = @TCL_MAJOR_VERSION@
@@ -283,7 +283,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \
tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \
tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \
- tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
+ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \
tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
tclPkg.o tclPkgConfig.o tclPosixStr.o \
@@ -395,6 +395,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclIOSock.c \
$(GENERIC_DIR)/tclIOUtil.c \
$(GENERIC_DIR)/tclIORChan.c \
+ $(GENERIC_DIR)/tclIORTrans.c \
$(GENERIC_DIR)/tclLink.c \
$(GENERIC_DIR)/tclListObj.c \
$(GENERIC_DIR)/tclLiteral.c \
@@ -1073,6 +1074,9 @@ tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c $(FSHDR)
tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c $(IOHDR)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c
+tclIORTrans.o: $(GENERIC_DIR)/tclIORTrans.c $(IOHDR)
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORTrans.c
+
tclLink.o: $(GENERIC_DIR)/tclLink.c
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c
diff --git a/win/Makefile.in b/win/Makefile.in
index 13d3109..5e32d59 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -4,7 +4,7 @@
# "./configure", which is a configuration script generated by the "autoconf"
# program (constructs like "@foo@" will get replaced in the actual Makefile.
#
-# RCS: @(#) $Id: Makefile.in,v 1.131 2008/06/01 02:44:54 mistachkin Exp $
+# RCS: @(#) $Id: Makefile.in,v 1.132 2008/06/06 19:46:42 andreas_kupries Exp $
VERSION = @TCL_VERSION@
@@ -241,6 +241,7 @@ GENERIC_OBJS = \
tclIOCmd.$(OBJEXT) \
tclIOGT.$(OBJEXT) \
tclIORChan.$(OBJEXT) \
+ tclIORTrans.$(OBJEXT) \
tclIOSock.$(OBJEXT) \
tclIOUtil.$(OBJEXT) \
tclLink.$(OBJEXT) \
diff --git a/win/makefile.vc b/win/makefile.vc
index b33da87..27dc974 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -13,7 +13,7 @@
# Copyright (c) 2003-2008 Pat Thoyts.
#
#------------------------------------------------------------------------------
-# RCS: @(#) $Id: makefile.vc,v 1.182 2008/06/01 02:44:54 mistachkin Exp $
+# RCS: @(#) $Id: makefile.vc,v 1.183 2008/06/06 19:46:42 andreas_kupries Exp $
#------------------------------------------------------------------------------
# Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR)
@@ -278,6 +278,7 @@ TCLOBJS = \
$(TMP_DIR)\tclIOSock.obj \
$(TMP_DIR)\tclIOUtil.obj \
$(TMP_DIR)\tclIORChan.obj \
+ $(TMP_DIR)\tclIORTrans.obj \
$(TMP_DIR)\tclLink.obj \
$(TMP_DIR)\tclListObj.obj \
$(TMP_DIR)\tclLiteral.obj \