From 17aeda99fb77f6fa2cd10e1dbc86bc85e57fe242 Mon Sep 17 00:00:00 2001 From: andreas_kupries Date: Fri, 6 Jun 2008 19:46:35 +0000 Subject: 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. --- ChangeLog | 21 + generic/tclIOCmd.c | 4 +- generic/tclIORTrans.c | 3345 +++++++++++++++++++++++++++++++++++++++++++++++++ generic/tclInt.h | 6 +- generic/tclVar.c | 4 +- tests/chan.test | 4 +- tests/ioCmd.test | 6 +- tests/ioTrans.test | 1463 +++++++++++++++++++++ unix/Makefile.in | 8 +- win/Makefile.in | 3 +- win/makefile.vc | 3 +- 11 files changed, 4855 insertions(+), 12 deletions(-) create mode 100644 generic/tclIORTrans.c create mode 100644 tests/ioTrans.test diff --git a/ChangeLog b/ChangeLog index a84cd49..cb4114c 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,24 @@ +2008-06-06 Andreas Kupries + + 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 * 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 +#include +#include + +#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; iargv[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; iargv[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, ¶mPtr->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 +# +# +# 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 \ -- cgit v0.12