diff options
| -rw-r--r-- | ChangeLog | 21 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 4 | ||||
| -rw-r--r-- | generic/tclIORTrans.c | 3345 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclVar.c | 4 | ||||
| -rw-r--r-- | tests/chan.test | 4 | ||||
| -rw-r--r-- | tests/ioCmd.test | 6 | ||||
| -rw-r--r-- | tests/ioTrans.test | 1463 | ||||
| -rw-r--r-- | unix/Makefile.in | 8 | ||||
| -rw-r--r-- | win/Makefile.in | 3 | ||||
| -rw-r--r-- | win/makefile.vc | 3 |
11 files changed, 4855 insertions, 12 deletions
@@ -1,3 +1,24 @@ +2008-06-06 Andreas Kupries <andreask@activestate.com> + + TIP #230 IMPLEMENTATION + + * generic/tclIOCmd.c: Integration of transform commands into 'chan' ensemble. + * generic/tclInt.h: Definitions of the transform commands. + * generic/tclIORTrans.c: Implementation of the reflection transforms. + * tests/chan.test: Tests updated for new sub-commands of 'chan'. + * tests/ioCmd.test: Tests updated for new sub-commands of 'chan'. + * tests/ioTrans.test: Whole new set of tests for the reflection transform. + * unix/Makefile.in: Integration of new files into build rules. + * win/Makefile.in: Integration of new files into build rules. + * win/makefile.vc: Integration of new files into build rules. + + NOTE: The file 'tclIORTrans.c' has a lot of code in common with + the file 'tclIORChan.c', as that made it much easier to + develop the reference implementation as a separate + module. Now that the transforms have been committed the one + thing left to do is to go over both modules and see which of + the common parts we can factor out and share. + 2008-06-04 Pat Thoyts <patthoyts@users.sourceforge.net> * generic/tclBinary.c: TIP #317 implementation diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index be34dc1..131b905 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.53 2008/04/10 20:58:59 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.54 2008/06/06 19:46:36 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1838,7 +1838,9 @@ TclInitChanCmd( {"flush", Tcl_FlushObjCmd}, {"gets", Tcl_GetsObjCmd}, {"pending", ChanPendingObjCmd}, /* TIP #287 */ + {"pop", TclChanPopObjCmd}, /* TIP #230 */ {"postevent", TclChanPostEventObjCmd}, /* TIP #219 */ + {"push", TclChanPushObjCmd}, /* TIP #230 */ {"puts", Tcl_PutsObjCmd}, {"read", Tcl_ReadObjCmd}, {"seek", Tcl_SeekObjCmd}, diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c new file mode 100644 index 0000000..908c480 --- /dev/null +++ b/generic/tclIORTrans.c @@ -0,0 +1,3345 @@ +/* + * tclIORTrans.c -- + * + * This file contains the implementation of Tcl's generic transformation + * reflection code, which allows the implementation of Tcl channel + * transformations in Tcl code. + * + * Parts of this file are based on code contributed by Jean-Claude + * Wippler. + * + * See TIP #230 for the specification of this functionality. + * + * Copyright (c) 2007-2008 ActiveState. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclIORTrans.c,v 1.1 2008/06/06 19:46:37 andreas_kupries Exp $ + */ + +#include <tclInt.h> +#include <tclIO.h> +#include <assert.h> + +#ifndef EINVAL +#define EINVAL 9 +#endif +#ifndef EOK +#define EOK 0 +#endif + +/* DUPLICATE of HaveVersion() in tclIO.c // TODO - MODULE_SCOPE */ +static int HaveVersion(const Tcl_ChannelType *typePtr, + Tcl_ChannelTypeVersion minimumVersion); + +/* + * Signatures of all functions used in the C layer of the reflection. + */ + +static int ReflectClose(ClientData clientData, + Tcl_Interp *interp); +static int ReflectInput(ClientData clientData, char *buf, + int toRead, int *errorCodePtr); +static int ReflectOutput(ClientData clientData, const char *buf, + int toWrite, int *errorCodePtr); +static void ReflectWatch(ClientData clientData, int mask); +static int ReflectBlock(ClientData clientData, int mode); +static Tcl_WideInt ReflectSeekWide(ClientData clientData, + Tcl_WideInt offset, int mode, int *errorCodePtr); +static int ReflectSeek(ClientData clientData, long offset, + int mode, int *errorCodePtr); +static int ReflectGetOption(ClientData clientData, + Tcl_Interp *interp, const char *optionName, + Tcl_DString *dsPtr); +static int ReflectSetOption(ClientData clientData, + Tcl_Interp *interp, const char *optionName, + const char *newValue); +static int ReflectHandle(ClientData clientData, int direction, + ClientData* handle); +static int ReflectNotify(ClientData clientData, int mask); + +/* + * The C layer channel type/driver definition used by the reflection. This is + * a version 3 structure. + */ + +static Tcl_ChannelType tclRTransformType = { + "tclrtransform", /* Type name. */ + TCL_CHANNEL_VERSION_5, /* v5 channel */ + ReflectClose, /* Close channel, clean instance data */ + ReflectInput, /* Handle read request */ + ReflectOutput, /* Handle write request */ + ReflectSeek, /* Move location of access point. */ + ReflectSetOption, /* Set options. */ + ReflectGetOption, /* Get options. */ + ReflectWatch, /* Initialize notifier */ + ReflectHandle, /* Get OS handle from the channel. */ + NULL, /* No close2 support. NULL'able */ + ReflectBlock, /* Set blocking/nonblocking. */ + NULL, /* Flush channel. Not used by core. NULL'able */ + ReflectNotify, /* Handle events. */ + ReflectSeekWide, /* Move access point (64 bit). */ + NULL, /* thread action */ + NULL, /* truncate */ +}; + +/* + * Structure of the buffer to hold transform results to be consumed by higher + * layers upon reading from the channel, plus the functions to manage such. + */ + +typedef struct _ResultBuffer_ { + unsigned char* buf; /* Reference to the buffer area */ + int allocated; /* Allocated size of the buffer area */ + int used; /* Number of bytes in the buffer, <= allocated */ +} ResultBuffer; + +#define ResultLength(r) ((r)->used) +/* static int ResultLength (ResultBuffer* r); */ + +static void ResultClear (ResultBuffer* r); +static void ResultInit (ResultBuffer* r); +static void ResultAdd (ResultBuffer* r, unsigned char* buf, int toWrite); +static int ResultCopy (ResultBuffer* r, unsigned char* buf, int toRead); + +#define RB_INCREMENT (512) + +/* + * Instance data for a reflected transformation. =========================== + */ + +typedef struct { + Tcl_Channel chan; /* Back reference to the channel of the + * transformation itself. */ + Tcl_Channel parent; /* Reference to the channel the transformation + * was pushed on. */ + Tcl_Interp *interp; /* Reference to the interpreter containing the + * Tcl level part of the channel. */ + Tcl_Obj *handle; /* Reference to transform handle. Also stored + * in the argv, see below. The separate field + * gives us direct access, needed when working + * with the reflection maps. + */ +#ifdef TCL_THREADS + Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ +#endif + + Tcl_TimerToken timer; + + /* See [==] as well. + * Storage for the command prefix and the additional words required for + * the invocation of methods in the command handler. + * + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + * ~~~~ CT ~~~ ~~ CT ~~ + * + * CT = Belongs to the 'Command handler Thread'. + */ + + int argc; /* Number of preallocated words - 2 */ + Tcl_Obj **argv; /* Preallocated array for calling the handler. + * args[0] is placeholder for cmd word. + * Followed by the arguments in the prefix, + * plus 4 placeholders for method, channel, + * and at most two varying (method specific) + * words. */ + int methods; /* Bitmask of supported methods */ + + /* + * NOTE (9): Should we have predefined shared literals for the method + * names? + */ + + int mode; /* Mask of R/W mode */ + int nonblocking; /* Flag: Channel is blocking or not */ + int readIsDrained; /* Flag: Read buffers are flushed*/ + + ResultBuffer result; + +} ReflectedTransform; + +/* + * Structure of the table mapping from transform handles to reflected + * transform (channels). Each interpreter which has the handler command for + * one or more reflected transforms records them in such a table, so that we + * are able to find them during interpreter/thread cleanup even if the actual + * channel they belong to was moved to a different interpreter and/or thread. + * + * The table is reachable via the standard interpreter AssocData, the key is + * defined below. + */ + +typedef struct { + Tcl_HashTable map; +} ReflectedTransformMap; + +#define RTMKEY "ReflectedTransformMap" + +/* + * Method literals. ================================================== + */ + +static const char *methodNames[] = { + "clear", /* OPT */ + "drain", /* OPT, drain => read */ + "finalize", /* */ + "flush", /* OPT, flush => write */ + "initialize", /* */ + "limit?", /* OPT */ + "read", /* OPT */ + "write", /* OPT */ + NULL +}; +typedef enum { + METH_CLEAR, + METH_DRAIN, + METH_FINAL, + METH_FLUSH, + METH_INIT, + METH_LIMIT, + METH_READ, + METH_WRITE +} MethodName; + +#define FLAG(m) (1 << (m)) +#define REQUIRED_METHODS \ + (FLAG(METH_INIT) | FLAG(METH_FINAL)) +#define RANDW \ + (TCL_READABLE | TCL_WRITABLE) + +#define IMPLIES(a,b) ((!(a)) || (b)) +#define NEGIMPL(a,b) +#define HAS(x,f) (x & FLAG(f)) + +#ifdef TCL_THREADS +/* + * Thread specific types and structures. + * + * We are here essentially creating a very specific implementation of 'thread + * send'. + */ + +/* + * Enumeration of all operations which can be forwarded. + */ + +typedef enum { + ForwardedClear, + ForwardedClose, + ForwardedDrain, + ForwardedFlush, + ForwardedInput, + ForwardedLimit, + ForwardedOutput +} ForwardedOperation; + +/* + * Event used to forward driver invocations to the thread actually managing + * the channel. We cannot construct the command to execute and forward + * that. Because then it will contain a mixture of Tcl_Obj's belonging to both + * the command handler thread (CT), and the thread managing the channel (MT), + * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we + * forward an operation code, the argument details, and reference to results. + * The command is assembled in the CT and belongs fully to that thread. No + * sharing problems. + */ + +typedef struct ForwardParamBase { + int code; /* O: Ok/Fail of the cmd handler */ + char *msgStr; /* O: Error message for handler failure */ + int mustFree; /* O: True if msgStr is allocated, false if + * otherwise (static). */ +} ForwardParamBase; + +/* + * Operation specific parameter/result structures. (These are "subtypes" of + * ForwardParamBase. Where an operation does not need any special types, it + * has no "subtype" and just uses ForwardParamBase, as listed above.) + */ + +struct ForwardParamTransform { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + char *buf; /* I: Bytes to transform, + * O: Bytes in transform result */ + int size; /* I: #bytes to transform, + * O: #bytes in the transform result */ +}; +struct ForwardParamLimit { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + int max; /* O: Character read limit */ +}; + +/* + * Now join all these together in a single union for convenience. + */ + +typedef union ForwardParam { + ForwardParamBase base; + struct ForwardParamTransform transform; + struct ForwardParamLimit limit; +} ForwardParam; + +/* + * Forward declaration. + */ + +typedef struct ForwardingResult ForwardingResult; + +/* + * General event structure, with reference to operation specific data. + */ + +typedef struct ForwardingEvent { + Tcl_Event event; /* Basic event data, has to be first item */ + ForwardingResult *resultPtr; + ForwardedOperation op; /* Forwarded driver operation */ + ReflectedTransform *rtPtr; /* Channel instance */ + ForwardParam *param; /* Packaged arguments and return values, a + * ForwardParam pointer. */ +} ForwardingEvent; + +/* + * Structure to manage the result of the forwarding. This is not the result of + * the operation itself, but about the success of the forward event itself. + * The event can be successful, even if the operation which was forwarded + * failed. It is also there to manage the synchronization between the involved + * threads. + */ + +struct ForwardingResult { + Tcl_ThreadId src; /* Originating thread. */ + Tcl_ThreadId dst; /* Thread the op was forwarded to. */ + Tcl_Interp *dsti; /* Interpreter in the thread the op was + * forwarded to. */ + Tcl_Condition done; /* Condition variable the forwarder blocks + * on. */ + int result; /* TCL_OK or TCL_ERROR */ + ForwardingEvent *evPtr; /* Event the result belongs to. */ + ForwardingResult *prevPtr, *nextPtr; + /* Links into the list of pending forwarded + * results. */ +}; + +typedef struct ThreadSpecificData { + /* + * Table of all reflected transformations owned by this thread. + */ + + ReflectedTransformMap* rtmPtr; +} ThreadSpecificData; + +static Tcl_ThreadDataKey dataKey; + +/* + * List of forwarded operations which have not completed yet, plus the mutex + * to protect the access to this process global list. + */ + +static ForwardingResult *forwardList = NULL; +TCL_DECLARE_MUTEX(rtForwardMutex) + +/* + * Function containing the generic code executing a forward, and wrapper + * macros for the actual operations we wish to forward. Uses ForwardProc as + * the event function executed by the thread receiving a forwarding event + * (which executes the appropriate function and collects the result, if any). + * + * The two ExitProcs are handlers so that things do not deadlock when either + * thread involved in the forwarding exits. They also clean things up so that + * we don't leak resources when threads go away. + */ + +static void ForwardOpToOwnerThread(ReflectedTransform *rtPtr, + ForwardedOperation op, const VOID *param); +static int ForwardProc(Tcl_Event *evPtr, int mask); +static void SrcExitProc(ClientData clientData); + +#define FreeReceivedError(p) \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ + } +#define PassReceivedErrorInterp(i,p) \ + if ((i) != NULL) { \ + Tcl_SetChannelErrorInterp((i), \ + Tcl_NewStringObj((p)->base.msgStr, -1)); \ + } \ + FreeReceivedError(p) +#define PassReceivedError(c,p) \ + Tcl_SetChannelError((c), Tcl_NewStringObj((p)->base.msgStr, -1)); \ + FreeReceivedError(p) +#define ForwardSetStaticError(p,emsg) \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 0; \ + (p)->base.msgStr = (char *) (emsg) +#define ForwardSetDynamicError(p,emsg) \ + (p)->base.code = TCL_ERROR; \ + (p)->base.mustFree = 1; \ + (p)->base.msgStr = (char *) (emsg) + +static void ForwardSetObjError(ForwardParam *p, + Tcl_Obj *objPtr); + +static ReflectedTransformMap * GetThreadReflectedTransformMap(void); +static void DeleteThreadReflectedTransformMap(ClientData clientData); + +#endif /* TCL_THREADS */ + +#define SetChannelErrorStr(c,msgStr) \ + Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) + +static Tcl_Obj * MarshallError(Tcl_Interp *interp); +static void UnmarshallErrorResult(Tcl_Interp *interp, + Tcl_Obj *msgObj); + +/* + * Static functions for this file: + */ + +static Tcl_Obj * DecodeEventMask(int mask); +static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp, + Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj, + Tcl_Channel parentChan); +static Tcl_Obj * NextHandle(void); +static void FreeReflectedTransform(ReflectedTransform *rtPtr); +static int InvokeTclMethod(ReflectedTransform *rtPtr, + const char *method, Tcl_Obj *argOneObj, + Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr); + +static ReflectedTransformMap * GetReflectedTransformMap(Tcl_Interp *interp); +static void DeleteReflectedTransformMap(ClientData clientData, + Tcl_Interp *interp); + +/* + * Global constant strings (messages). ================== + * These string are used directly as bypass errors, thus they have to be valid + * Tcl lists where the last element is the message itself. Hence the + * list-quoting to keep the words of the message together. See also [x]. + */ + +static const char *msg_read_badlimit = "{Tcl driver returned bad read limit '0'}"; +static const char *msg_read_unsup = "{read not supported by Tcl driver}"; +static const char *msg_write_unsup = "{write not supported by Tcl driver}"; +#ifdef TCL_THREADS +static const char *msg_send_originlost = "{Channel thread lost}"; +static const char *msg_send_dstlost = "{Owner lost}"; +#endif /* TCL_THREADS */ +static const char *msg_dstlost = "-code 1 -level 0 -errorcode NONE -errorinfo {} -errorline 1 {Owner lost}"; + +/* + * Timer management (flushing out buffered data via artificial events). + */ + +/* + * Number of milliseconds to wait before firing an event to try to + * flush out information waiting in buffers (fileevent support). + */ + +#define FLUSH_DELAY (5) + +static void TimerKill (ReflectedTransform* rtPtr); +static void TimerSetup (ReflectedTransform* rtPtr); +static void TimerRun (ClientData clientData); + +/* + * Helper functions encapsulating some of the thread forwarding to make the + * control flow in callers easier. + */ + +static int TransformRead (ReflectedTransform* rtPtr, int* errorCodePtr, unsigned char* buf, int toRead); +static int TransformWrite (ReflectedTransform* rtPtr, int* errorCodePtr, unsigned char* buf, int toWrite); +static int TransformDrain (ReflectedTransform* rtPtr, int* errorCodePtr); +static int TransformFlush (ReflectedTransform* rtPtr, int* errorCodePtr, int op); +static void TransformClear (ReflectedTransform* rtPtr); +static int TransformLimit (ReflectedTransform* rtPtr, int* errorCodePtr, int* maxPtr); + +/* op'codes for TransformFlush */ +#define FLUSH_WRITE 1 +#define FLUSH_DISCARD 0 + +/* + * Main methods to plug into the 'chan' ensemble'. ================== + */ + +/* + *---------------------------------------------------------------------- + * + * TclChanPushObjCmd -- + * + * This function is invoked to process the "chan push" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. The handle of the new channel is placed in the + * interp result. + * + * Side effects: + * Creates a new channel. + * + *---------------------------------------------------------------------- + */ + +int +TclChanPushObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + ReflectedTransform *rtPtr; /* Instance data of the new (transform) channel */ + Tcl_Obj* chanObj; /* Handle of parent channel */ + Tcl_Channel parentChan; /* Token of parent channel */ + int mode; /* R/W mode of parent, later the new + * channel. Has to match the abilities of the + * handler commands */ + Tcl_Obj *cmdObj; /* Command prefix, list of words */ + Tcl_Obj *cmdNameObj; /* Command name */ + Tcl_Obj *rtId; /* Handle of the new transform (channel) */ + Tcl_Obj *modeObj; /* mode in obj form for method call */ + + int listc; /* Result of 'initialize', and of */ + Tcl_Obj **listv; /* its sublist in the 2nd element */ + int methIndex; /* Encoded method name */ + int result; /* Result code for 'initialize' */ + Tcl_Obj *resObj; /* Result data for 'initialize' */ + int methods; /* Bitmask for supported methods. */ + Tcl_Obj *err; /* Error message */ + ReflectedTransformMap *rtmPtr; + /* Map of reflected transforms with handlers in + * this interp. */ + Tcl_HashEntry *hPtr; /* Entry in the above map */ + int isNew; /* Placeholder. */ + + /* + * Syntax: chan push CHANNEL CMDPREFIX + * [0] [1] [2] [3] + * + * Actually: rPush CHANNEL CMDPREFIX + * [0] [1] [2] + */ + +#define CHAN (1) +#define CMD (2) + + /* + * Number of arguments... + */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "channel cmdprefix"); + return TCL_ERROR; + } + + /* + * First argument is a channel handle. + */ + + chanObj = objv[CHAN]; + parentChan = Tcl_GetChannel (interp, Tcl_GetString (chanObj), &mode); + if (parentChan == NULL) { + return TCL_ERROR; + } + parentChan = Tcl_GetTopChannel (parentChan); + + /* + * Second argument is command prefix, i.e. list of words, first word is + * name of handler command, other words are fixed arguments. Run + * 'initialize' method to get the list of supported methods. Validate + * this. + */ + + cmdObj = objv[CMD]; + + /* + * Basic check that the command prefix truly is a list. + */ + + if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Now create the transformation (channel). + */ + + rtId = NextHandle(); + rtPtr = NewReflectedTransform(interp, cmdObj, mode, rtId, parentChan); + + /* + * Invoke 'initialize' and validate that the handler is present and ok. + * Squash the transformation if not. + */ + + modeObj = DecodeEventMask(mode); + result = InvokeTclMethod(rtPtr, "initialize", modeObj, NULL, &resObj); + Tcl_DecrRefCount(modeObj); + if (result != TCL_OK) { + UnmarshallErrorResult(interp, resObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + goto error; + } + + /* + * Verify the result. + * - List, of method names. Convert to mask. + * Check for non-optionals through the mask. + * Compare open mode against optional r/w. + */ + + if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1); + Tcl_AppendObjToObj(err, resObj); + Tcl_SetObjResult(interp, err); + Tcl_DecrRefCount(resObj); + goto error; + } + + methods = 0; + while (listc > 0) { + if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, + "method", TCL_EXACT, &methIndex) != TCL_OK) { + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, " initialize\" returned ", -1); + Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); + Tcl_SetObjResult(interp, err); + Tcl_DecrRefCount(resObj); + goto error; + } + + methods |= FLAG(methIndex); + listc--; + } + Tcl_DecrRefCount(resObj); + + if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" does not support all required methods", -1); + Tcl_SetObjResult(interp, err); + goto error; + } + + /* + * Mode tell us what the parent channel supports. The methods tell us what + * the handler supports. We remove the non-supported bits from the mode + * and check that the channel is not completely inacessible. Afterward the + * mode tells us which methods are still required, and these methods will + * also be supported by the handler, by design of the check. + */ + + if (!HAS(methods, METH_READ)) { mode &= ~TCL_READABLE; } + if (!HAS(methods, METH_WRITE)) { mode &= ~TCL_WRITABLE; } + + if (!mode) { + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" makes the channel inacessible", -1); + Tcl_SetObjResult(interp, err); + goto error; + } + + /* + * The mode and support for it is ok, now check the internal constraints. + */ + + if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1); + Tcl_SetObjResult(interp, err); + goto error; + } + + if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { + TclNewLiteralStringObj(err, "chan handler \""); + Tcl_AppendObjToObj(err, cmdObj); + Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1); + Tcl_SetObjResult(interp, err); + goto error; + } + + Tcl_ResetResult(interp); + + /* + * Everything is fine now. + */ + + rtPtr->methods = methods; + rtPtr->mode = mode; + rtPtr->chan = Tcl_StackChannel (interp, &tclRTransformType, + (ClientData) rtPtr, mode, + rtPtr->parent); + + /* + * Register the transform in our our map for proper handling of deleted + * interpreters and/or threads. + */ + + rtmPtr = GetReflectedTransformMap (interp); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), + &isNew); + if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) { + Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle"); + } + Tcl_SetHashValue(hPtr, rtPtr); +#ifdef TCL_THREADS + rtmPtr = GetThreadReflectedTransformMap(); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), + &isNew); + Tcl_SetHashValue(hPtr, rtPtr); +#endif + + /* + * Return the channel as the result of the command. + */ + + Tcl_AppendResult (interp, Tcl_GetChannelName (rtPtr->chan), + (char*) NULL); + return TCL_OK; + + error: + /* + * We are not going through ReflectClose as we never had a channel + * structure. + */ + + FreeReflectedTransform(rtPtr); + return TCL_ERROR; + +#undef CHAN +#undef CMD +} + +/* + *---------------------------------------------------------------------- + * + * TclChanPopObjCmd -- + * + * This function is invoked to process the "chan pop" Tcl command. + * See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Posts events to a reflected channel, invokes event handlers. The + * latter implies that arbitrary side effects are possible. + * + *---------------------------------------------------------------------- + */ + +int +TclChanPopObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + /* + * Syntax: chan pop CHANNEL + * [0] [1] [2] + * + * Actually: rPop CHANNEL + * [0] [1] + */ + +#define CHAN (1) + + const char *chanId; /* Tcl level channel handle */ + Tcl_Channel chan; /* Channel associated to the handle */ + int mode; /* Channel r/w mode */ + + /* + * Number of arguments... + */ + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channel"); + return TCL_ERROR; + } + + /* + * First argument is a channel, which may have a (reflected) + * transformation. + */ + + chanId = TclGetString(objv[CHAN]); + chan = Tcl_GetChannel(interp, chanId, &mode); + + if (chan == NULL) { + return TCL_ERROR; + } + + /* Removing transformations is generic, and not restricted to reflected + * transformations. + */ + + Tcl_UnstackChannel(interp, chan); + return TCL_OK; + +#undef CHAN +} + +/* + * Channel error message marshalling utilities. + */ + +static Tcl_Obj* +MarshallError( + Tcl_Interp *interp) +{ + /* + * Capture the result status of the interpreter into a string. => List of + * options and values, followed by the error message. The result has + * refCount 0. + */ + + Tcl_Obj *returnOpt = Tcl_GetReturnOptions(interp, TCL_ERROR); + + /* + * => returnOpt.refCount == 0. We can append directly. + */ + + Tcl_ListObjAppendElement(NULL, returnOpt, Tcl_GetObjResult(interp)); + return returnOpt; +} + +static void +UnmarshallErrorResult( + Tcl_Interp *interp, + Tcl_Obj *msgObj) +{ + int lc; + Tcl_Obj **lv; + int explicitResult; + int numOptions; + + /* + * Process the caught message. + * + * Syntax = (option value)... ?message? + * + * Bad syntax causes a panic. This is OK because the other side uses + * Tcl_GetReturnOptions and list construction functions to marshall the + * information; if we panic here, something has gone badly wrong already. + */ + + if (Tcl_ListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) { + Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result"); + } + if (interp == NULL) { + return; + } + + explicitResult = lc & 1; /* Odd number of values? */ + numOptions = lc - explicitResult; + + if (explicitResult) { + Tcl_SetObjResult(interp, lv[lc-1]); + } + + (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv)); + ((Interp *)interp)->flags &= ~ERR_ALREADY_LOGGED; +} + +/* + * Driver functions. ================================================ + */ + +/* + *---------------------------------------------------------------------- + * + * ReflectClose -- + * + * This function is invoked when the channel is closed, to delete the + * driver specific instance data. + * + * Results: + * A posix error. + * + * Side effects: + * Releases memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectClose( + ClientData clientData, + Tcl_Interp *interp) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + int result; /* Result code for 'close' */ + Tcl_Obj *resObj; /* Result data for 'close' */ + ReflectedTransformMap *rtmPtr;/* Map of reflected transforms with handlers in + * this interp */ + Tcl_HashEntry *hPtr; /* Entry in the above map */ + + if (interp == NULL) { + /* + * This call comes from TclFinalizeIOSystem. There are no + * interpreters, and therefore we cannot call upon the handler command + * anymore. Threading is irrelevant as well. We simply clean up all + * our C level data structures and leave the Tcl level to the other + * finalization functions. + */ + + /* + * THREADED => Forward this to the origin thread + * + * Note: DeleteThreadReflectedTransformMap() is the thread exit handler + * for the origin thread. Use this to clean up the structure? Except + * if lost? + */ + +#ifdef TCL_THREADS + if (rtPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; + + ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); + result = p.base.code; + + /* + * FreeReflectedTransform is done in the forwarded operation!, in + * the other thread. rtPtr here is gone! + */ + + if (result != TCL_OK) { + FreeReceivedError(&p); + } + return EOK; + } +#endif + + FreeReflectedTransform(rtPtr); + return EOK; + } + + /* + * In the reflected channel implementation a cleaned method mask here + * implies that the channel creation was aborted, and "finalize" must not + * be called. for transformations however we are not going through here on + * such an abort, but directly through FreeReflectedTransform. So for us + * that check is not necessary. We always go through 'finalize'. + */ + + if (HAS(rtPtr->methods, METH_DRAIN) && (!rtPtr->readIsDrained)) { + int errorCode; + if (!TransformDrain (rtPtr, &errorCode)) { + return errorCode; + } + } + + if (HAS(rtPtr->methods, METH_FLUSH)) { + int errorCode; + if (!TransformFlush (rtPtr, &errorCode, FLUSH_WRITE)) { + return errorCode; + } + } + + /* + * Are we in the correct thread? + */ + +#ifdef TCL_THREADS + if (rtPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; + + ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p); + result = p.base.code; + + /* + * FreeReflectedTransform is done in the forwarded operation!, in the + * other thread. rtPtr here is gone! + */ + + if (result != TCL_OK) { + PassReceivedErrorInterp(interp, &p); + } + } else { +#endif + result = InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj); + if ((result != TCL_OK) && (interp != NULL)) { + Tcl_SetChannelErrorInterp(interp, resObj); + } + + Tcl_DecrRefCount(resObj); /* Remove reference we held from the + * invoke */ + + /* + * Remove the transform from the map before releasing the memory, to + * prevent future accesses from finding and dereferencing a dangling + * pointer. + * + * NOTE: The transform may not be in the map. This is ok, that happens + * when the transform was created in a different interpreter and/or + * thread and then was moved here. + */ + + rtmPtr = GetReflectedTransformMap(interp); + hPtr = Tcl_FindHashEntry (&rtmPtr->map, + Tcl_GetString(rtPtr->handle)); + if (hPtr) { + Tcl_DeleteHashEntry (hPtr); + } +#ifdef TCL_THREADS + /* + * In a threaded interpreter we manage a per-thread map as well, to + * allow us to survive if the script level pulls the rug out under a + * channel by deleting the owning thread. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + hPtr = Tcl_FindHashEntry (&rtmPtr->map, + Tcl_GetString(rtPtr->handle)); + if (hPtr) { + Tcl_DeleteHashEntry (hPtr); + } +#endif + + FreeReflectedTransform(rtPtr); +#ifdef TCL_THREADS + } +#endif + return (result == TCL_OK) ? EOK : EINVAL; +} + +/* + *---------------------------------------------------------------------- + * + * ReflectInput -- + * + * This function is invoked when more data is requested from the channel. + * + * Results: + * The number of bytes read. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectInput( + ClientData clientData, + char *buf, + int toRead, + int *errorCodePtr) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + int gotBytes, copied, read; + + /* + * The following check can be done before thread redirection, because we + * are reading from an item which is readonly, i.e. will never change + * during the lifetime of the channel. + */ + + if (!(rtPtr->methods & FLAG(METH_READ))) { + SetChannelErrorStr(rtPtr->chan, msg_read_unsup); + *errorCodePtr = EINVAL; + return -1; + } + + gotBytes = 0; + + while (toRead > 0) { + /* Loop until the request is satisfied (or no data available from + * below, possibly EOF). + */ + + copied = ResultCopy (&rtPtr->result, (unsigned char*) buf, toRead); + toRead -= copied; + buf += copied; + gotBytes += copied; + + if (toRead == 0) { + return gotBytes; + } + + /* + * The buffer is exhausted, but the caller wants even more. We now + * have to go to the underlying channel, get more bytes and then + * transform them for delivery. We may not get that we want (full EOF + * or temporary out of data). + */ + + /* + * Length (rtPtr->result) == 0, toRead > 0 here. Use 'buf'! as target + * to store the intermediary information read from the parent channel. + * + * Ask the transform how much data it allows us to read from the + * underlying channel. This feature allows the transform to signal EOF + * upstream although there is none downstream. Useful to control an + * unbounded 'fcopy' for example, either through counting bytes, or by + * pattern matching. + */ + + if ((rtPtr->methods & FLAG(METH_LIMIT))) { + int maxRead = -1; + if (!TransformLimit (rtPtr, errorCodePtr, &maxRead)) { + return -1; + } + if (maxRead == 0) { + SetChannelErrorStr(rtPtr->chan, msg_read_badlimit); + return -1; + } else if (maxRead > 0) { + if (maxRead < toRead) { + toRead = maxRead; + } + } /* else: 'maxRead < 0' == Accept the current value of toRead */ + } + + if (toRead <= 0) { + return gotBytes; + } + + read = Tcl_ReadRaw (rtPtr->parent, buf, toRead); + if (read < 0) { + /* Report errors to caller. + * The state of the seek system is unchanged! + */ + + if ((Tcl_GetErrno () == EAGAIN) && (gotBytes > 0)) { + /* EAGAIN is a special situation. If we had some data + * before we report that instead of the request to re-try. + */ + + return gotBytes; + } + + *errorCodePtr = Tcl_GetErrno (); + return -1; + } + + if (read == 0) { + /* + * Check wether we hit on EOF in 'parent' or not. If not + * differentiate between blocking and non-blocking modes. In + * non-blocking mode we ran temporarily out of data. Signal this + * to the caller via EWOULDBLOCK and error return (-1). In the + * other cases we simply return what we got and let the caller + * wait for more. On the other hand, if we got an EOF we have to + * convert and flush all waiting partial data. + */ + + if (!Tcl_Eof (rtPtr->parent)) { + /* The state of the seek system is unchanged! */ + + if ((gotBytes == 0) && rtPtr->nonblocking) { + *errorCodePtr = EWOULDBLOCK; + return -1; + } else { + return gotBytes; + } + } else { + /* Eof in parent */ + if (rtPtr->readIsDrained) { + return gotBytes; + } + + /* + * Now this is a bit different. The partial data waiting is + * converted and returned. + */ + + if (HAS(rtPtr->methods, METH_DRAIN)) { + if(!TransformDrain (rtPtr, errorCodePtr)) { + return -1; + } + } + + if (ResultLength (&rtPtr->result) == 0) { + /* The drain delivered nothing */ + return gotBytes; + } + continue; /* at: while (toRead > 0) */ + } + } /* read == 0 */ + + /* + * Transform the read chunk, which was not empty. Anything we got back + * is a transformation result is put into our buffers, and the next + * iteration will put it into the result. + */ + + if (!TransformRead (rtPtr, errorCodePtr, buf, read)) { + return -1; + } + } /* while toRead > 0 */ + + return gotBytes; + +} + +/* + *---------------------------------------------------------------------- + * + * ReflectOutput -- + * + * This function is invoked when data is writen to the channel. + * + * Results: + * The number of bytes actually written. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectOutput( + ClientData clientData, + const char *buf, + int toWrite, + int *errorCodePtr) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + + /* + * The following check can be done before thread redirection, because we + * are reading from an item which is readonly, i.e. will never change + * during the lifetime of the channel. + */ + + if (!(rtPtr->methods & FLAG(METH_WRITE))) { + SetChannelErrorStr(rtPtr->chan, msg_write_unsup); + *errorCodePtr = EINVAL; + return -1; + } + + if (toWrite == 0) { + /* Nothing came in to write, ignore the call + */ + return 0; + } + + /* + * Discard partial data in the input buffers, i.e. on the read side. Like + * we do when explicitly seeking as well. + */ + + if ((rtPtr->methods & FLAG(METH_CLEAR))) { + TransformClear (rtPtr); + } + + /* + * Hand the data to the transformation itself. Anything it deigned to + * return to us is a (partial) transformation result and written to the + * parent channel for further processing. + */ + + if (!TransformWrite (rtPtr, errorCodePtr, (unsigned char*) buf, toWrite)) { + return -1; + } + + *errorCodePtr = EOK; + return toWrite; +} + +/* + *---------------------------------------------------------------------- + * + * ReflectSeekWide / ReflectSeek -- + * + * This function is invoked when the user wishes to seek on the channel. + * + * Results: + * The new location of the access point. + * + * Side effects: + * Allocates memory. Arbitrary, per the parent channel, and the called scripts. + * + *---------------------------------------------------------------------- + */ + +static Tcl_WideInt +ReflectSeekWide( + ClientData clientData, + Tcl_WideInt offset, + int seekMode, + int *errorCodePtr) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + Channel* parent = (Channel*) rtPtr->parent; + Tcl_WideInt curPos; /* Position on the device. */ + + Tcl_DriverSeekProc *seekProc = + Tcl_ChannelSeekProc(Tcl_GetChannelType (rtPtr->parent)); + + /* + * Fail if the parent channel is not seekable. + */ + + if (seekProc == NULL) { + Tcl_SetErrno(EINVAL); + return Tcl_LongAsWide(-1); + } + + /* + * Check if we can leave out involving the Tcl level, i.e. transformation + * handler. This is true for tell requests, and transformations which + * support neither flush, nor drain. For these cases we can pass the + * request down and the result back up unchanged. + */ + + if ( + ((seekMode != SEEK_CUR) || (offset != 0)) && + (HAS(rtPtr->methods, METH_CLEAR) || + HAS(rtPtr->methods, METH_FLUSH)) + ) { + /* + * Neither a tell request, nor clear/flush both not supported. We + * have to go through the Tcl level to clear and/or flush the + * transformation. + */ + + if ((rtPtr->methods & FLAG(METH_CLEAR))) { + TransformClear (rtPtr); + } + + /* + * When flushing the transform for seeking the generated results are + * irrelevant. We cannot put them into the channel, this would move + * the location, throwing it off with regard to where we are and are + * seeking to. + */ + + if (HAS(rtPtr->methods, METH_FLUSH)) { + if (!TransformFlush (rtPtr, errorCodePtr, FLUSH_DISCARD)) { + return -1; + } + } + } + + /* + * Now seek to the new position in the channel as requested by the + * caller. Note that we prefer the wideSeekProc if that is available and + * non-NULL... + */ + + if (HaveVersion(parent->typePtr, TCL_CHANNEL_VERSION_3) && + parent->typePtr->wideSeekProc != NULL) { + curPos = (parent->typePtr->wideSeekProc) (parent->instanceData, + offset, seekMode, errorCodePtr); + } else if (offset < Tcl_LongAsWide(LONG_MIN) || + offset > Tcl_LongAsWide(LONG_MAX)) { + *errorCodePtr = EOVERFLOW; + curPos = Tcl_LongAsWide(-1); + } else { + curPos = Tcl_LongAsWide((parent->typePtr->seekProc) ( + parent->instanceData, Tcl_WideAsLong(offset), seekMode, + errorCodePtr)); + } + if (curPos == Tcl_LongAsWide(-1)) { + Tcl_SetErrno(*errorCodePtr); + } + + *errorCodePtr = EOK; + return curPos; +} + +static int +ReflectSeek( + ClientData clientData, + long offset, + int seekMode, + int *errorCodePtr) +{ + /* + * This function can be invoked from a transformation which is based on + * standard seeking, i.e. non-wide. Because of this we have to implement + * it, a dummy is not enough. We simply delegate the call to the wide + * routine. + */ + + return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, + errorCodePtr); +} + +/* + *---------------------------------------------------------------------- + * + * ReflectWatch -- + * + * This function is invoked to tell the channel what events the I/O + * system is interested in. + * + * Results: + * None. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static void +ReflectWatch( + ClientData clientData, + int mask) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + Tcl_DriverWatchProc* watchProc; + + watchProc = Tcl_ChannelWatchProc (Tcl_GetChannelType (rtPtr->parent)); + (*watchProc) (Tcl_GetChannelInstanceData(rtPtr->parent), + mask); + + /* + * Management of the internal timer. + */ + + if (!(mask & TCL_READABLE) || (ResultLength(&rtPtr->result) == 0)) { + /* + * A pending timer may exist, but either is there no (more) interest + * in the events it generates or nothing is available for + * reading. Remove it, if existing. + */ + + TimerKill (rtPtr); + } else { + /* + * There might be no pending timer, but there is interest in readable + * events and we actually have data waiting, so generate a timer to + * flush that if it does not exist. + */ + + TimerSetup (rtPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * ReflectBlock -- + * + * This function is invoked to tell the channel which blocking behaviour + * is required of it. + * + * Results: + * A posix error number. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectBlock( + ClientData clientData, + int nonblocking) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + + /* + * Transformations simply record the blocking mode in their C level + * structure for use by --> ReflectInput. The Tcl level doesn't see this + * information or change. As such thread forwarding is not required. + */ + + rtPtr->nonblocking = nonblocking; + return EOK; +} + +/* + *---------------------------------------------------------------------- + * + * ReflectSetOption -- + * + * This function is invoked to configure a channel option. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, per the parent channel. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectSetOption( + ClientData clientData, /* Channel to query */ + Tcl_Interp *interp, /* Interpreter to leave error messages in */ + const char *optionName, /* Name of requested option */ + const char *newValue) /* The new value */ +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + + /* + * Transformations have no options. Thus the call is passed down unchanged + * to the parent channel for processing. Its results are passed back + * unchanged as well. This all happens in the thread we are in. As the Tcl + * level is not involved there is no need for thread forwarding. + */ + + Tcl_DriverSetOptionProc *setOptionProc = + Tcl_ChannelSetOptionProc (Tcl_GetChannelType (rtPtr->parent)); + + if (setOptionProc != NULL) { + return (*setOptionProc) (Tcl_GetChannelInstanceData (rtPtr->parent), + interp, optionName, newValue); + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ReflectGetOption -- + * + * This function is invoked to retrieve all or a channel options. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, per the parent channel. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectGetOption( + ClientData clientData, /* Channel to query */ + Tcl_Interp *interp, /* Interpreter to leave error messages in */ + const char *optionName, /* Name of reuqested option */ + Tcl_DString *dsPtr) /* String to place the result into */ +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + + /* + * Transformations have no options. Thus the call is passed down unchanged + * to the parent channel for processing. Its results are passed back + * unchanged as well. This all happens in the thread we are in. As the Tcl + * level is not involved there is no need for thread forwarding. + * + * Note that the parent not having a driver for option retrieval is not an + * immediate error. A query for all options is ok. Only a request for a + * specific option has to fail. + */ + + Tcl_DriverGetOptionProc *getOptionProc = + Tcl_ChannelGetOptionProc (Tcl_GetChannelType (rtPtr->parent)); + + if (getOptionProc != NULL) { + return (*getOptionProc) (Tcl_GetChannelInstanceData (rtPtr->parent), + interp, optionName, dsPtr); + } else if (optionName == (char*) NULL) { + return TCL_OK; + } else { + return TCL_ERROR; + } +} + +/* + *---------------------------------------------------------------------- + * + * ReflectHandle -- + * + * This function is invoked to retrieve the associated file handle. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, per the parent channel. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectHandle( + ClientData clientData, + int direction, + ClientData* handlePtr) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + + /* + * Transformations have no handle of their own. As such we simply query + * the parent channel for it. This way the qery will ripple down through + * all transformations until reaches the base channel. Which then returns + * its handle, or fails. The former will then ripple up the stack. + * + * This all happens in the thread we are in. As the Tcl level is not + * involved no forwarding is required. + */ + + return Tcl_GetChannelHandle (rtPtr->parent, direction, handlePtr); +} +/* + *---------------------------------------------------------------------- + * + * ReflectNotify -- + * + * This function is invoked to reported incoming events. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, per the parent channel. + * + *---------------------------------------------------------------------- + */ + +static int +ReflectNotify( + ClientData clientData, + int mask) +{ + ReflectedTransform *rtPtr = (ReflectedTransform *) clientData; + + /* + * An event occured in the underlying channel. + * + * We delete our timer. It was not fired, yet we are here, so the channel + * below generated such an event and we don't have to. The renewal of the + * interest after the execution of channel handlers will eventually cause + * us to recreate the timer (in ReflectWatch). + */ + + TimerKill (rtPtr); + + /* + * Pass to higher layers. + */ + + return mask; +} + +/* + * Helpers. ========================================================= + */ + + +/* + *---------------------------------------------------------------------- + * + * DecodeEventMask -- + * + * This function takes an internal bitmask of events and constructs the + * equivalent list of event items. + * + * Results: + * A Tcl_Obj reference. The object will have a refCount of one. The user + * has to decrement it to release the object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + * DUPLICATE of 'DecodeEventMask' in tclIORChan.c + */ + +static Tcl_Obj * +DecodeEventMask( + int mask) +{ + register const char *eventStr; + Tcl_Obj *evObj; + + switch (mask & RANDW) { + case RANDW: + eventStr = "read write"; + break; + case TCL_READABLE: + eventStr = "read"; + break; + case TCL_WRITABLE: + eventStr = "write"; + break; + default: + eventStr = ""; + break; + } + + evObj = Tcl_NewStringObj(eventStr, -1); + Tcl_IncrRefCount(evObj); + return evObj; +} + +/* + *---------------------------------------------------------------------- + * + * NewReflectedTransform -- + * + * This function is invoked to allocate and initialize the instance data + * of a new reflected channel. + * + * Results: + * A heap-allocated channel instance. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +static ReflectedTransform * +NewReflectedTransform( + Tcl_Interp *interp, + Tcl_Obj *cmdpfxObj, + int mode, + Tcl_Obj *handleObj, + Tcl_Channel parentChan) +{ + ReflectedTransform *rtPtr; + int listc; + Tcl_Obj **listv; + int i; + + rtPtr = (ReflectedTransform *) ckalloc(sizeof(ReflectedTransform)); + + /* rtPtr->chan: Assigned by caller. Dummy data here. */ + /* rtPtr->methods: Assigned by caller. Dummy data here. */ + + rtPtr->chan = NULL; + rtPtr->methods = 0; +#ifdef TCL_THREADS + rtPtr->thread = Tcl_GetCurrentThread(); +#endif + rtPtr->parent = parentChan; + rtPtr->interp = interp; + rtPtr->handle = handleObj; + Tcl_IncrRefCount(handleObj); + rtPtr->timer = (Tcl_TimerToken) NULL; + rtPtr->mode = 0; + rtPtr->readIsDrained = 0; + rtPtr->nonblocking = + (((Channel*) parentChan)->state->flags & CHANNEL_NONBLOCKING); + /* Query parent for current blocking mode. */ + + ResultInit (&rtPtr->result); + + /* + * Method placeholder. + */ + + /* ASSERT: cmdpfxObj is a Tcl List */ + + Tcl_ListObjGetElements(interp, cmdpfxObj, &listc, &listv); + + /* + * See [==] as well. + * Storage for the command prefix and the additional words required for + * the invocation of methods in the command handler. + * + * listv [0] [listc-1] | [listc] [listc+1] | + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + */ + + rtPtr->argc = listc + 2; + rtPtr->argv = (Tcl_Obj**) ckalloc(sizeof(Tcl_Obj*) * (listc+4)); + + /* + * Duplicate object references. + */ + + for (i=0; i<listc ; i++) { + Tcl_Obj *word = rtPtr->argv[i] = listv[i]; + Tcl_IncrRefCount(word); + } + + i++; /* Skip placeholder for method */ + + /* + * See [x] in FreeReflectedTransform for release + */ + rtPtr->argv[i] = handleObj; + Tcl_IncrRefCount(handleObj); + + /* + * The next two objects are kept empty, varying arguments. + */ + + /* + * Initialization complete. + */ + + return rtPtr; +} + +/* + *---------------------------------------------------------------------- + * + * NextHandle -- + * + * This function is invoked to generate a channel handle for a new + * reflected channel. + * + * Results: + * A Tcl_Obj containing the string of the new channel handle. The + * refcount of the returned object is -- zero --. + * + * Side effects: + * May allocate memory. Mutex protected critical section locks out other + * threads for a short time. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj * +NextHandle(void) +{ + /* + * Count number of generated reflected channels. Used for id generation. + * Ids are never reclaimed and there is no dealing with wrap around. On + * the other hand, "unsigned long" should be big enough except for + * absolute longrunners (generate a 100 ids per second => overflow will + * occur in 1 1/3 years). + */ + + TCL_DECLARE_MUTEX(rtCounterMutex) + static unsigned long rtCounter = 0; + Tcl_Obj *resObj; + + Tcl_MutexLock(&rtCounterMutex); + resObj = Tcl_ObjPrintf("rt%lu", rtCounter); + rtCounter++; + Tcl_MutexUnlock(&rtCounterMutex); + + return resObj; +} + +static void +FreeReflectedTransform( + ReflectedTransform *rtPtr) +{ + int i, n; + + TimerKill (rtPtr); + ResultClear (&rtPtr->result); + + Tcl_DecrRefCount(rtPtr->handle); + rtPtr->handle = NULL; + + n = rtPtr->argc - 2; + for (i=0; i<n; i++) { + Tcl_DecrRefCount(rtPtr->argv[i]); + } + + /* + * See [x] in NewReflectedTransform for lock + * n+1 = argc-1. + */ + Tcl_DecrRefCount(rtPtr->argv[n+1]); + + ckfree((char*) rtPtr->argv); + ckfree((char*) rtPtr); +} + +/* + *---------------------------------------------------------------------- + * + * InvokeTclMethod -- + * + * This function is used to invoke the Tcl level of a reflected channel. + * It handles all the command assembly, invokation, and generic state and + * result mgmt. It does *not* handle thread redirection; that is the + * responsibility of clients of this function. + * + * Results: + * Result code and data as returned by the method. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + * Semi-DUPLICATE of 'InvokeTclMethod' in tclIORChan.c + * - Semi because different structures are used. + * - Still possible to factor out the commonalities into a separate structure. + */ + +static int +InvokeTclMethod( + ReflectedTransform *rtPtr, + const char *method, + Tcl_Obj *argOneObj, /* NULL'able */ + Tcl_Obj *argTwoObj, /* NULL'able */ + Tcl_Obj **resultObjPtr) /* NULL'able */ +{ + int cmdc; /* #words in constructed command */ + Tcl_Obj *methObj = NULL; /* Method name in object form */ + Tcl_InterpState sr; /* State of handler interp */ + int result; /* Result code of method invokation */ + Tcl_Obj *resObj = NULL; /* Result of method invokation. */ + + if (!rtPtr->interp) { + /* + * The transform is marked as dead. Bail out immediately, with an + * appropriate error. + */ + + if (resultObjPtr != NULL) { + resObj = Tcl_NewStringObj(msg_dstlost,-1); + *resultObjPtr = resObj; + Tcl_IncrRefCount(resObj); + } + return TCL_ERROR; + } + + /* + * NOTE (5): Decide impl. issue: Cache objects with method names? + * Requires TSD data as reflections can be created in many different + * threads. + * NO: Caching of command resolutions means storage per channel. + */ + + /* + * Insert method into the pre-allocated area, after the command prefix, + * before the channel id. + */ + + methObj = Tcl_NewStringObj(method, -1); + Tcl_IncrRefCount(methObj); + rtPtr->argv[rtPtr->argc - 2] = methObj; + + /* + * Append the additional argument containing method specific details + * behind the channel id. If specified. + */ + + cmdc = rtPtr->argc; + if (argOneObj) { + Tcl_IncrRefCount(argOneObj); + rtPtr->argv[cmdc] = argOneObj; + cmdc++; + if (argTwoObj) { + Tcl_IncrRefCount(argTwoObj); + rtPtr->argv[cmdc] = argTwoObj; + cmdc++; + } + } + + /* + * And run the handler... This is done in auch a manner which leaves any + * existing state intact. + */ + + sr = Tcl_SaveInterpState(rtPtr->interp, 0 /* Dummy */); + Tcl_Preserve(rtPtr->interp); + result = Tcl_EvalObjv(rtPtr->interp, cmdc, rtPtr->argv, TCL_EVAL_GLOBAL); + + /* + * We do not try to extract the result information if the caller has no + * interest in it. I.e. there is no need to put effort into creating + * something which is discarded immediately after. + */ + + if (resultObjPtr) { + if (result == TCL_OK) { + /* + * Ok result taken as is, also if the caller requests that there + * is no capture. + */ + + resObj = Tcl_GetObjResult(rtPtr->interp); + } else { + /* + * Non-ok result is always treated as an error. We have to capture + * the full state of the result, including additional options. + * + * This is complex and ugly, and would be completely unnecessary + * if we only added support for a TCL_FORBID_EXCEPTIONS flag. + */ + if (result != TCL_ERROR) { + Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); + int cmdLen; + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + + Tcl_IncrRefCount(cmd); + Tcl_ResetResult(rtPtr->interp); + Tcl_SetObjResult(rtPtr->interp, Tcl_ObjPrintf( + "chan handler returned bad code: %d", result)); + Tcl_LogCommandInfo(rtPtr->interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(cmd); + result = TCL_ERROR; + } + Tcl_AppendObjToErrorInfo(rtPtr->interp, Tcl_ObjPrintf( + "\n (chan handler subcommand \"%s\")", method)); + resObj = MarshallError(rtPtr->interp); + } + Tcl_IncrRefCount(resObj); + } + Tcl_RestoreInterpState(rtPtr->interp, sr); + Tcl_Release(rtPtr->interp); + + /* + * Cleanup of the dynamic parts of the command. + */ + + Tcl_DecrRefCount(methObj); + if (argOneObj) { + Tcl_DecrRefCount(argOneObj); + if (argTwoObj) { + Tcl_DecrRefCount(argTwoObj); + } + } + + /* + * The resObj has a ref count of 1 at this location. This means that the + * caller of InvokeTclMethod has to dispose of it (but only if it was + * returned to it). + */ + + if (resultObjPtr != NULL) { + *resultObjPtr = resObj; + } + + /* + * There no need to handle the case where nothing is returned, because for + * that case resObj was not set anyway. + */ + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * GetReflectedTransformMap -- + * + * Gets and potentially initializes the reflected channel map for an + * interpreter. + * + * Results: + * A pointer to the map created, for use by the caller. + * + * Side effects: + * Initializes the reflected channel map for an interpreter. + * + *---------------------------------------------------------------------- + */ + +static ReflectedTransformMap * +GetReflectedTransformMap( + Tcl_Interp *interp) +{ + ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL); + + if (rtmPtr == NULL) { + rtmPtr = (ReflectedTransformMap *) ckalloc(sizeof(ReflectedTransformMap)); + Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS); + Tcl_SetAssocData(interp, RTMKEY, + (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr); + } + return rtmPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteReflectedTransformMap -- + * + * Deletes the channel table for an interpreter, closing any open + * channels whose refcount reaches zero. This procedure is invoked when + * an interpreter is deleted, via the AssocData cleanup mechanism. + * + * Results: + * None. + * + * Side effects: + * Deletes the hash table of channels. May close channels. May flush + * output on closed channels. Removes any channeEvent handlers that were + * registered in this interpreter. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteReflectedTransformMap( + ClientData clientData, /* The per-interpreter data structure. */ + Tcl_Interp *interp) /* The interpreter being deleted. */ +{ + ReflectedTransformMap *rtmPtr; /* The map */ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + ReflectedTransform *rtPtr; + +#ifdef TCL_THREADS + ForwardingResult *resultPtr; + ForwardingEvent *evPtr; + ForwardParam *paramPtr; +#endif + + /* + * Delete all entries. The channels may have been closed already, or will + * be closed later, by the standard IO finalization of an interpreter + * under destruction. Except for the channels which were moved to a + * different interpreter and/or thread. They do not exist from the IO + * systems point of view and will not get closed. Therefore mark all as + * dead so that any future access will cause a proper error. For channels + * in a different thread we actually do the same as + * DeleteThreadReflectedTransformMap(), just restricted to the channels of + * this interp. + */ + + rtmPtr = clientData; + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { + rtPtr = (ReflectedTransform *) Tcl_GetHashValue (hPtr); + + //fprintf(stdout,"[%ld] dd t-rcm %p /h %p /rt %p\n", (long)Tcl_GetCurrentThread(),rtmPtr,hPtr,rtPtr);fflush(stdout); + + + rtPtr->interp = NULL; + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&rtmPtr->map); + ckfree((char *) &rtmPtr->map); + +#ifdef TCL_THREADS + /* + * The origin interpreter for one or more reflected channels is gone. + */ + + /* + * Go through the list of pending results and cancel all whose events were + * destined for this interpreter. While this is in progress we block any + * other access to the list of pending results. + */ + + Tcl_MutexLock(&rtForwardMutex); + + for (resultPtr = forwardList; + resultPtr != NULL; + resultPtr = resultPtr->nextPtr) { + if (resultPtr->dsti != interp) { + /* + * Ignore results/events for other interpreters. + */ + + continue; + } + + /* + * The receiver for the event exited, before processing the event. We + * detach the result now, wake the originator up and signal failure. + */ + + evPtr = resultPtr->evPtr; + paramPtr = evPtr->param; + + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; + + ForwardSetStaticError(paramPtr, msg_send_dstlost); + + Tcl_ConditionNotify(&resultPtr->done); + } + + /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels and remove all which were handled by this + * interpreter. They have already been marked as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_NextHashEntry(&hSearch)) { + rtPtr = (ReflectedTransform *) Tcl_GetHashValue (hPtr); + + if (rtPtr->interp != interp) { + /* + * Ignore entries for other interpreters. + */ + + continue; + } + + Tcl_DeleteHashEntry(hPtr); + } + + Tcl_MutexUnlock(&rtForwardMutex); +#endif +} + +#ifdef TCL_THREADS +/* + *---------------------------------------------------------------------- + * + * GetThreadReflectedTransformMap -- + * + * Gets and potentially initializes the reflected channel map for a + * thread. + * + * Results: + * A pointer to the map created, for use by the caller. + * + * Side effects: + * Initializes the reflected channel map for a thread. + * + *---------------------------------------------------------------------- + */ + +static ReflectedTransformMap * +GetThreadReflectedTransformMap(void) +{ + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + + if (!tsdPtr->rtmPtr) { + tsdPtr->rtmPtr = (ReflectedTransformMap *) + ckalloc(sizeof(ReflectedTransformMap)); + Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS); + Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL); + } + + return tsdPtr->rtmPtr; +} + +/* + *---------------------------------------------------------------------- + * + * DeleteThreadReflectedTransformMap -- + * + * Deletes the channel table for a thread. This procedure is invoked when + * a thread is deleted. The channels have already been marked as dead, in + * DeleteReflectedTransformMap(). + * + * Results: + * None. + * + * Side effects: + * Deletes the hash table of channels. + * + *---------------------------------------------------------------------- + */ + +static void +DeleteThreadReflectedTransformMap( + ClientData clientData) /* The per-thread data structure. */ +{ + Tcl_HashSearch hSearch; /* Search variable. */ + Tcl_HashEntry *hPtr; /* Search variable. */ + Tcl_ThreadId self = Tcl_GetCurrentThread(); + ReflectedTransformMap *rtmPtr; /* The map */ + ForwardingResult *resultPtr; + + /* + * The origin thread for one or more reflected channels is gone. + * NOTE: If this function is called due to a thread getting killed the + * per-interp DeleteReflectedTransformMap is apparently not called. + */ + + /* + * Go through the list of pending results and cancel all whose events were + * destined for this thread. While this is in progress we block any + * other access to the list of pending results. + */ + + Tcl_MutexLock(&rtForwardMutex); + + for (resultPtr = forwardList; + resultPtr != NULL; + resultPtr = resultPtr->nextPtr) { + ForwardingEvent *evPtr; + ForwardParam *paramPtr; + + if (resultPtr->dst != self) { + /* + * Ignore results/events for other threads. + */ + + continue; + } + + /* + * The receiver for the event exited, before processing the event. We + * detach the result now, wake the originator up and signal failure. + */ + + evPtr = resultPtr->evPtr; + paramPtr = evPtr->param; + + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; + + ForwardSetStaticError(paramPtr, msg_send_dstlost); + + Tcl_ConditionNotify(&resultPtr->done); + } + + /* + * Get the map of all channels handled by the current thread. This is a + * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go + * through the channels, remove all, mark them as dead. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch); + hPtr != NULL; + hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) { + ReflectedTransform *rtPtr = (ReflectedTransform *) Tcl_GetHashValue(hPtr); + + rtPtr->interp = NULL; + Tcl_DeleteHashEntry(hPtr); + } + + Tcl_MutexUnlock(&rtForwardMutex); +} + +static void +ForwardOpToOwnerThread( + ReflectedTransform *rtPtr, /* Channel instance */ + ForwardedOperation op, /* Forwarded driver operation */ + const VOID *param) /* Arguments */ +{ + Tcl_ThreadId dst = rtPtr->thread; + ForwardingEvent *evPtr; + ForwardingResult *resultPtr; + int result; + + /* + * We gather the lock early. This allows us to check the liveness of the + * channel without interference from DeleteThreadReflectedTransformMap(). + */ + + Tcl_MutexLock(&rtForwardMutex); + + if (rtPtr->interp == NULL) { + /* + * The channel is marked as dead. Bail out immediately, with an + * appropriate error. Do not forget to unlock the mutex on this path. + */ + + ForwardSetStaticError((ForwardParam *) param, msg_send_dstlost); + Tcl_MutexUnlock(&rtForwardMutex); + return; + } + + /* + * Create and initialize the event and data structures. + */ + + evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult)); + + evPtr->event.proc = ForwardProc; + evPtr->resultPtr = resultPtr; + evPtr->op = op; + evPtr->rtPtr = rtPtr; + evPtr->param = (ForwardParam *) param; + + resultPtr->src = Tcl_GetCurrentThread(); + resultPtr->dst = dst; + resultPtr->done = NULL; + resultPtr->result = -1; + resultPtr->evPtr = evPtr; + + /* + * Now execute the forward. + */ + + TclSpliceIn(resultPtr, forwardList); + /* Do not unlock here. That is done by the ConditionWait */ + + /* + * Ensure cleanup of the event if the origin thread exits while this event + * is pending or in progress. Exit of the destination thread is handled by + * DeleteThreadReflectionChannelMap(), this is set up by + * GetThreadReflectedTransformMap(). This is what we use the 'forwardList' + * (see above) for. + */ + + Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr); + + /* + * Queue the event and poke the other thread's notifier. + */ + + Tcl_ThreadQueueEvent(dst, (Tcl_Event *)evPtr, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(dst); + + /* + * (*) Block until the other thread has either processed the transfer or + * rejected it. + */ + + while (resultPtr->result < 0) { + /* + * NOTE (1): Is it possible that the current thread goes away while + * waiting here? IOW Is it possible that "SrcExitProc" is called + * while we are here? See complementary note (2) in "SrcExitProc" + * + * The ConditionWait unlocks the mutex during the wait and relocks it + * immediately after. + */ + + Tcl_ConditionWait(&resultPtr->done, &rtForwardMutex, NULL); + } + + /* + * Unlink result from the forwarder list. No need to lock. Either still + * locked, or locked by the ConditionWait + */ + + TclSpliceOut(resultPtr, forwardList); + + resultPtr->nextPtr = NULL; + resultPtr->prevPtr = NULL; + + Tcl_MutexUnlock(&rtForwardMutex); + Tcl_ConditionFinalize(&resultPtr->done); + + /* + * Kill the cleanup handler now, and the result structure as well, before + * returning the success code. + * + * Note: The event structure has already been deleted by the destination + * notifier, after it serviced the event. + */ + + Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr); + + result = resultPtr->result; + ckfree((char*) resultPtr); +} + +static int +ForwardProc( + Tcl_Event *evGPtr, + int mask) +{ + /* + * Notes regarding access to the referenced data. + * + * In principle the data belongs to the originating thread (see + * evPtr->src), however this thread is currently blocked at (*), i.e. + * quiescent. Because of this we can treat the data as belonging to us, + * without fear of race conditions. I.e. we can read and write as we like. + * + * The only thing we cannot be sure of is the resultPtr. This can be be + * NULLed if the originating thread went away while the event is handled + * here now. + */ + + ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr; + ForwardingResult *resultPtr = evPtr->resultPtr; + ReflectedTransform *rtPtr = evPtr->rtPtr; + Tcl_Interp *interp = rtPtr->interp; + ForwardParam *paramPtr = evPtr->param; + Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ + ReflectedTransformMap* rtmPtr; /* Map of reflected channels with handlers in this interp */ + Tcl_HashEntry* hPtr; /* Entry in the above map */ + + /* + * Ignore the event if no one is waiting for its result anymore. + */ + + if (!resultPtr) { + return 1; + } + + paramPtr->base.code = TCL_OK; + paramPtr->base.msgStr = NULL; + paramPtr->base.mustFree = 0; + + switch (evPtr->op) { + /* + * The destination thread for the following operations is + * rtPtr->thread, which contains rtPtr->interp, the interp we have to + * call upon for the driver. + */ + + case ForwardedClose: + /* + * No parameters/results. + */ + + if (InvokeTclMethod(rtPtr, "finalize", NULL, NULL, &resObj) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } + + /* + * Freeing is done here, in the origin thread, because the argv[] + * objects belong to this thread. Deallocating them in a different + * thread is not allowed + */ + + /* + * Remove the channel from the map before releasing the memory, to + * prevent future accesses (like by 'postevent') from finding and + * dereferencing a dangling pointer. + */ + + rtmPtr = GetReflectedTransformMap (interp); + hPtr = Tcl_FindHashEntry (&rtmPtr->map, + Tcl_GetString(rtPtr->handle)); + Tcl_DeleteHashEntry (hPtr); + + /* + * In a threaded interpreter we manage a per-thread map as well, to + * allow us to survive if the script level pulls the rug out under a + * channel by deleting the owning thread. + */ + + rtmPtr = GetThreadReflectedTransformMap(); + hPtr = Tcl_FindHashEntry (&rtmPtr->map, + Tcl_GetString(rtPtr->handle)); + Tcl_DeleteHashEntry (hPtr); + FreeReflectedTransform(rtPtr); + break; + + case ForwardedInput: { + Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) paramPtr->transform.buf, + paramPtr->transform.size); + + if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->transform.size = -1; + } else { + /* + * Process a regular return. Contains the transformation result. + * Sent it back to the request originator. + */ + + int bytec; /* Number of returned bytes */ + unsigned char *bytev; /* Array of returned bytes */ + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + paramPtr->transform.size = bytec; + + if (bytec > 0) { + paramPtr->transform.buf = ckalloc (bytec); + memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + } else { + paramPtr->transform.buf = NULL; + } + } + break; + } + + case ForwardedOutput: { + Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) paramPtr->transform.buf, + paramPtr->transform.size); + + if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->transform.size = -1; + } else { + /* + * Process a regular return. Contains the transformation result. + * Sent it back to the request originator. + */ + + int bytec; /* Number of returned bytes */ + unsigned char *bytev; /* Array of returned bytes */ + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + paramPtr->transform.size = bytec; + + if (bytec > 0) { + paramPtr->transform.buf = ckalloc (bytec); + memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + } else { + paramPtr->transform.buf = NULL; + } + } + break; + } + + case ForwardedDrain: { + if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->transform.size = -1; + } else { + /* + * Process a regular return. Contains the transformation result. + * Sent it back to the request originator. + */ + + int bytec; /* Number of returned bytes */ + unsigned char *bytev; /* Array of returned bytes */ + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + paramPtr->transform.size = bytec; + + if (bytec > 0) { + paramPtr->transform.buf = ckalloc (bytec); + memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + } else { + paramPtr->transform.buf = NULL; + } + } + break; + } + + case ForwardedFlush: { + if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->transform.size = -1; + } else { + /* + * Process a regular return. Contains the transformation result. + * Sent it back to the request originator. + */ + + int bytec; /* Number of returned bytes */ + unsigned char *bytev; /* Array of returned bytes */ + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + paramPtr->transform.size = bytec; + + if (bytec > 0) { + paramPtr->transform.buf = ckalloc (bytec); + memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + } else { + paramPtr->transform.buf = NULL; + } + } + break; + } + + case ForwardedClear: { + (void) InvokeTclMethod(rtPtr, "clear", NULL, NULL, NULL); + break; + } + + case ForwardedLimit: { + Tcl_Obj* resObj; + + if (InvokeTclMethod(rtPtr, "limit?", NULL, NULL, &resObj) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->limit.max = -1; + } else if (Tcl_GetIntFromObj(interp, resObj, ¶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 <andreask@activestate.com> +# <akupries@shaw.ca> +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. +# +# RCS: @(#) $Id: ioTrans.test,v 1.1 2008/06/06 19:46:42 andreas_kupries Exp $ + +if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* +} + +# Custom constraints used in this file +testConstraint testchannel [llength [info commands testchannel]] +testConstraint testthread [llength [info commands testthread]] + +# testchannel cut|splice Both needed to test the reflection in threads. +# testthread send + +#---------------------------------------------------------------------- + +# ### ### ### ######### ######### ######### +## Testing the reflected transformation. + +# Helper commands to record the arguments to handler methods. Stored +# in a script so that the tests needing this code do not need their +# own copy but can access this variable. + +set helperscript { + if {[lsearch [namespace children] ::tcltest] == -1} { + package require tcltest 2 + namespace import -force ::tcltest::* + } + + proc note {item} {global res; lappend res $item; return} + proc track {} {upvar args item; note $item; return} + proc notes {items} {foreach i $items {note $i}} + + # Use to prevent *'s in pattern to match beyond the expected end + # of the recording. + proc endnote {} {note |} + + # This forces the return options to be in the order that the test + # expects! + proc noteOpts opts {global res; lappend res [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! + } $opts]; return} + + # Helper command, canned result for 'initialize' method. Gets the + # optional methods as arguments. Use return features to post the + # result higher up. + + proc init {args} { + lappend args initialize finalize read write + return -code return $args + } + proc oninit {args} { + upvar args hargs + if {[lindex $hargs 0] ne "initialize"} {return} + lappend args initialize finalize read write + return -code return $args + } + proc onfinal {} { + upvar args hargs + if {[lindex $hargs 0] ne "finalize"} {return} + return -code return "" + } + proc onread {} { + upvar args hargs + if {[lindex $hargs 0] ne "read"} {return} + return -code return "@" + } + proc ondrain {} { + upvar args hargs + if {[lindex $hargs 0] ne "drain"} {return} + return -code return "<>" + } + proc onclear {} { + upvar args hargs + if {[lindex $hargs 0] ne "clear"} {return} + return -code return "" + } + + proc tempchan {{mode r+}} { + global tempchan + set tempchan [open [makeFile {test data} tempchanfile] $mode] + return $tempchan + } + + proc tempdone {} { + global tempchan + catch {close $tempchan} + removeFile tempchanfile + return + } + + proc tempview {} { viewFile tempchanfile } +} + +# Set everything up in the main thread. +eval $helperscript + +#puts <<[file channels]>> + +# ### ### ### ######### ######### ######### + +test iortrans-1.0 {chan, wrong#args} { + catch {chan} msg + set msg +} {wrong # args: should be "chan subcommand ?argument ...?"} +test iortrans-1.1 {chan, unknown method} { + catch {chan foo} msg + set msg +} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, pending, pop, postevent, push, puts, read, seek, tell, or truncate} + +# --- --- --- --------- --------- --------- +# chan push, and method "initalize" + +test iortrans-2.0 {chan push, wrong#args, not enough} { + catch {chan push} msg + set msg +} {wrong # args: should be "chan push channel cmdprefix"} +test iortrans-2.1 {chan push, wrong#args, too many} { + catch {chan push a b c} msg + set msg +} {wrong # args: should be "chan push channel cmdprefix"} +test iortrans-2.2 {chan push, invalid channel} { + proc foo {} {} + catch {chan push {} foo} msg + rename foo {} + set msg +} {can not find channel named ""} +test iortrans-2.3 {chan push, bad handler, not a list} { + catch {chan push [tempchan] "foo \{"} msg + tempdone + set msg +} {unmatched open brace in list} +test iortrans-2.4 {chan push, bad handler, not a command} { + catch {chan push [tempchan] foo} msg + tempdone + set msg +} {invalid command name "foo"} +test iortrans-2.5 {chan push, initialize failed, bad signature} { + proc foo {} {} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} {wrong # args: should be "foo"} +test iortrans-2.6 {chan push, initialize failed, bad signature} { + proc foo {} {} + catch {chan push [tempchan] ::foo} msg + tempdone + rename foo {} + set msg +} {wrong # args: should be "::foo"} +test iortrans-2.7 {chan push, initialize failed, bad result, not a list} -body { + proc foo {args} {return "\{"} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set ::errorInfo +} -match glob -result {chan handler "foo initialize" returned non-list: *} +test iortrans-2.8 {chan push, initialize failed, bad result, not a list} -body { + proc foo {args} {return \{\{\}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {chan handler "foo initialize" returned non-list: *} +test iortrans-2.9 {chan push, initialize failed, bad result, empty list} -body { + proc foo {args} {} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*all required methods*} +test iortrans-2.10 {chan push, initialize failed, bad result, bogus method name} -body { + proc foo {args} {return 1} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*bad method "1": must be *} +test iortrans-2.11 {chan push, initialize failed, bad result, bogus method name} -body { + proc foo {args} {return {a b c}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*bad method "c": must be *} +test iortrans-2.12 {chan push, initialize failed, bad result, required methods missing} -body { + # Required: initialize, and finalize. + proc foo {args} {return {initialize}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*all required methods*} +test iortrans-2.13 {chan push, initialize failed, bad result, illegal method name} -body { + proc foo {args} {return {initialize finalize BOGUS}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*returned bad method "BOGUS": must be clear, drain, finalize, flush, initialize, limit?, read, or write} +test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler mismatch} -body { + proc foo {args} {return {initialize finalize}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*makes the channel inacessible} +# iortrans-2.15 event/watch methods elimimated, removed these tests. +# iortrans-2.16 +test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body { + proc foo {args} {return {initialize finalize drain write}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*supports "drain" but not "read"} +test iortrans-2.18 {chan push, initialize failed, bad result, flush/write mismatch} -body { + proc foo {args} {return {initialize finalize flush read}} + catch {chan push [tempchan] foo} msg + tempdone + rename foo {} + set msg +} -match glob -result {*supports "flush" but not "write"} +test iortrans-2.19 {chan push, initialize ok, creates channel} -match glob -body { + proc foo {args} { + global res + lappend res $args + if {[lindex $args 0] ne "initialize"} {return} + return {initialize finalize drain flush read write} + } + set res {} + lappend res [file channel rt*] + lappend res [chan push [tempchan] foo] + lappend res [close [lindex $res end]] + lappend res [file channel rt*] + tempdone + rename foo {} + set res +} -result {{} {initialize rt* {read write}} file* {drain rt*} {flush rt*} {finalize rt*} {} {}} +test iortrans-2.20 {chan push, init failure -> no channel, no finalize} -match glob -body { + proc foo {args} { + global res + lappend res $args + return {} + } + set res {} + lappend res [file channel rt*] + lappend res [catch {chan push [tempchan] foo} msg] + lappend res $msg + lappend res [file channel rt*] + tempdone + rename foo {} + set res +} -result {{} {initialize rt* {read write}} 1 {*all required methods*} {}} + +# --- --- --- --------- --------- --------- +# method finalize (via close) + +# General note: file channels rt* finds the transform channel, however +# the name reported will be that of the underlying base driver, fileXX +# here. This actually allows us to see if the whole channel is gone, +# or only the transformation, but not the base. + +test iortrans-3.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { + set res {} + proc foo {args} {track; oninit; return} + note [set c [chan push [tempchan] foo]] + rename foo {} + note [file channels file*] + note [file channels rt*] + note [catch {close $c} msg]; note $msg + note [file channels file*] + note [file channels rt*] + set res +} -result {{initialize rt* {read write}} file* file* {} 1 {invalid command name "foo"} {} {}} +test iortrans-3.2 {chan finalize, for close} -match glob -body { + set res {} + proc foo {args} {track; oninit; return {}} + note [set c [chan push [tempchan] foo]] + close $c + # Close deleted the channel. + note [file channels rt*] + # Channel destruction does not kill handler command! + note [info command foo] + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} +test iortrans-3.3 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code error 5} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg]; note $msg + # Channel is gone despite error. + note [file channels rt*] + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} +test iortrans-3.4 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; error FOO} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg]; note $msg; note $::errorInfo + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO {FOO +*"close $c"}} +test iortrans-3.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { + set res {} + proc foo {args} {track; oninit; return SOMETHING} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg]; note $msg + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} +test iortrans-3.6 {chan finalize, for close, break, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code 3} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg]; note $msg + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans-3.7 {chan finalize, for close, continue, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code 4} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg]; note $msg + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans-3.8 {chan finalize, for close, custom code, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code 777 BANG} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg]; note $msg + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} +test iortrans-3.9 {chan finalize, for close, ignore level, close error} -match glob -setup { + set res {} +} -body { + proc foo {args} {track; oninit; return -level 5 -code 777 BANG} + note [set c [chan push [tempchan] foo]] + note [catch {close $c} msg opt]; note $msg; noteOpts $opt + return $res +} -cleanup { + rename foo {} +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} + +# --- === *** ########################### +# method read (via read) + +test iortrans-4.1 {chan read, transform call and return} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return snarf + } + set c [chan push [tempchan] foo] + note [read $c 10] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} snarf} +test iortrans-4.2 {chan read, for non-readable channel} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track; note MUST_NOT_HAPPEN + } + set c [chan push [tempchan w] foo] + note [catch {read $c 2} msg]; note $msg + tempdone + rename foo {} + set res +} -result {1 {channel "file*" wasn't opened for reading}} +test iortrans-4.3 {chan read, error return} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code error BOOM! + } + set c [chan push [tempchan] foo] + note [catch {read $c 2} msg]; note $msg + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 BOOM!} +test iortrans-4.4 {chan read, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code break BOOM! + } + set c [chan push [tempchan] foo] + note [catch {read $c 2} msg]; note $msg + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code*} +test iortrans-4.5 {chan read, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code continue BOOM! + } + set c [chan push [tempchan] foo] + note [catch {read $c 2} msg]; note $msg + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code*} +test iortrans-4.6 {chan read, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code 777 BOOM! + } + set c [chan push [tempchan] foo] + note [catch {read $c 2} msg]; note $msg + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code*} +test iortrans-4.7 {chan read, level is squashed} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -level 55 -code 777 BOOM! + } + set c [chan push [tempchan] foo] + note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} + + +# --- === *** ########################### +# method write (via puts) + +test iortrans-5.1 {chan write, regular write} -match glob -body { + set res {} + proc foo {args} { oninit; onfinal; track ; return transformresult } + set c [chan push [tempchan] foo] + puts -nonewline $c snarf; flush $c + close $c + note [tempview] + tempdone + rename foo {} + set res +} -result {{write rt* snarf} transformresult} +test iortrans-5.2 {chan write, no write is ok, no change to file} -match glob -body { + set res {} + proc foo {args} { oninit; onfinal; track ; return {} } + set c [chan push [tempchan] foo] + puts -nonewline $c snarfsnarfsnarf; flush $c + close $c + note [tempview];# This has to show the original data, as nothing was written + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} {test data}} +test iortrans-5.3 {chan write, failed write} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code error FAIL!} + set c [chan push [tempchan] foo] + puts -nonewline $c snarfsnarfsnarf + note [catch {flush $c} msg] ; note $msg + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 FAIL!} +test iortrans-5.4 {chan write, non-writable channel} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} + set c [chan push [tempchan r] foo] + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg]; note $msg + close $c + tempdone + rename foo {} + set res +} -result {1 {channel "file*" wasn't opened for writing}} +test iortrans-5.5 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code error BOOM!} + set c [chan push [tempchan] foo] + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans-5.6 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; error BOOM!} + set c [chan push [tempchan] foo] + notes [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} +test iortrans-5.7 {chan write, failed write, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code break BOOM!} + set c [chan push [tempchan] foo] + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans-5.8 {chan write, failed write, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} + set c [chan push [tempchan] foo] + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans-5.9 {chan write, failed write, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} + set c [chan push [tempchan] foo] + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} +test iortrans-5.10 {chan write, failed write, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} + set c [chan push [tempchan] foo] + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] + note $msg + noteOpts $opt + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} + +# --- === *** ########################### +# method limit?, drain (via read) + +test iortrans-6.1 {chan read, read limits} -match glob -body { + set res {} + proc foo {args} { + oninit limit?; onfinal; track ; onread + return 6 + } + set c [chan push [tempchan] foo] + note [read $c 10] + tempdone + rename foo {} + set res +} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata +}} {limit? rt*} @@} +test iortrans-6.2 {chan read, read transform drain on eof} -match glob -body { + set res {} + proc foo {args} { + oninit drain; onfinal; track ; onread ; ondrain + return + } + set c [chan push [tempchan] foo] + note [read $c] + note [close $c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} {drain rt*} @<> {}} + +# --- === *** ########################### +# method clear (via puts, seek) + +test iortrans-7.1 {chan write, write clears read buffers} -match glob -body { + set res {} + proc foo {args} { + oninit clear; onfinal; track ; onclear + return transformresult + } + set c [chan push [tempchan] foo] + puts -nonewline $c snarf; flush $c + tempdone + rename foo {} + set res +} -result {{clear rt*} {write rt* snarf}} +test iortrans-7.2 {seek clears read buffers} -match glob -body { + set res {} + proc foo {args} { + oninit clear; onfinal; track + return + } + set c [chan push [tempchan] foo] + seek $c 2 + tempdone + rename foo {} + set res +} -result {{clear rt*}} +test iortrans-7.3 {clear, any result is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit clear; onfinal; track + return -code error "X" + } + set c [chan push [tempchan] foo] + seek $c 2 + tempdone + rename foo {} + set res +} -result {{clear rt*}} + +# --- === *** ########################### +# method flush (via seek, close) + +test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body { + set res {} + proc foo {args} { + oninit flush; onfinal; track + return X + } + set c [chan push [tempchan] foo] + # Flush, no writing + seek $c 2 + # The close flushes again, this modifies the file! + note | ; note [close $c] ; note | + note [tempview] + tempdone + rename foo {} + set res +} -result {{flush rt*} | {flush rt*} {} | {teXt data}} + +test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body { + set res {} + proc foo {args} { + oninit flush; track ; onfinal + return .flushed. + } + set c [chan push [tempchan] foo] + close $c + note [tempview] + tempdone + rename foo {} + set res +} -result {{flush rt*} {finalize rt*} .flushed.} + + +# --- === *** ########################### +# method watch - removed from TIP (rev 1.12+) + +# --- === *** ########################### +# method event - removed from TIP (rev 1.12+) + +# --- === *** ########################### +# 'Pull the rug' tests. Create channel in a interpreter A, move to +# other interpreter B, destroy the origin interpreter (A) before or +# during access from B. Must not crash, must return proper errors. + +test iortrans-11.0 {origin interpreter of moved transform gone} -match glob -body { + + set ida [interp create];#puts <<$ida>> + set idb [interp create];#puts <<$idb>> + + # Magic to get the test* commands in the slaves + load {} Tcltest $ida + load {} Tcltest $idb + + # Set up channel and transform in interpreter + interp eval $ida $helperscript + set chan [interp eval $ida { + proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + set chan [chan push [tempchan] foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd interpreter, transform goes with it. + interp eval $ida [list testchannel cut $chan] + interp eval $idb [list testchannel splice $chan] + + # Kill origin interpreter, then access channel from 2nd interpreter. + interp delete $ida + + set res {} + lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg + lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg + lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg + lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg + lappend res [catch {interp eval $idb [list close $chan]} msg] $msg + #lappend res [interp eval $ida {set res}] + # actions: clear|write|clear|write|clear|flush|limit?|drain|flush + set res + # The 'tell' is ok, as it passed through the transform to the base + # channel without invoking the transform handler. +} -constraints {testchannel} \ + -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} + +test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -match glob -body { + + set ida [interp create];#puts <<$ida>> + set idb [interp create];#puts <<$idb>> + + # Magic to get the test* commands in the slaves + load {} Tcltest $ida + load {} Tcltest $idb + + # Set up channel in thread + set chan [interp eval $ida $helperscript] + set chan [interp eval $ida { + proc foo {args} { + oninit clear drain flush limit? read write; onfinal; track; + # destroy interpreter during channel access + # Actually not possible for an interp to destroy itself. + interp delete {} + return} + set chan [chan push [tempchan] foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd thread, transform goes with it. + interp eval $ida [list testchannel cut $chan] + interp eval $idb [list testchannel splice $chan] + + # Run access from interpreter B, this will give us a synchronous + # response. + + interp eval $idb [list set chan $chan] + interp eval $idb [list set mid $tcltest::mainThread] + set res [interp eval $idb { + # wait a bit, give the main thread the time to start its event + # loop to wait for the response from B + after 2000 + catch { puts $chan shoo } res + set res + }] + set res +} -constraints {testchannel impossible} \ + -result {Owner lost} + +# ### ### ### ######### ######### ######### +## Same tests as above, but exercising the code forwarding and +## receiving driver operations to the originator thread. + +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Testing the reflected channel (Thread forwarding). +# +## The id numbers refer to the original test without thread +## forwarding, and gaps due to tests not applicable to forwarding are +## left to keep this association. + +# Duplicate of code in "thread.test", and "ioCmd.test". Find a better +# way of doing this without duplication. Maybe placement into a proc +# which transforms to nop after the first call, and placement of its +# defintion in a central location. + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + proc ThreadNullError {id info} { + # ignore + } +} + +# ### ### ### ######### ######### ######### +## Helper command. Runs a script in a separate thread and returns the +## result. A channel is transfered into the thread as well, and a list +## of configuation variables + +proc inthread {chan script args} { + # Test thread. + + set tid [testthread create] + + # Init thread configuration. + # - Listed variables + # - Id of main thread + # - A number of helper commands + + foreach v $args { + upvar 1 $v x + testthread send $tid [list set $v $x] + } + testthread send $tid [list set mid $tcltest::mainThread] + testthread send $tid { + proc note {item} {global notes; lappend notes $item} + proc notes {} {global notes; return $notes} + proc noteOpts opts {global notes; lappend notes [dict merge { + -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?! + } $opts]} + } + testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*) + + # Transfer channel (cut/splice aka detach/attach) + + testchannel cut $chan + testthread send $tid [list testchannel splice $chan] + + # Run test script, also run local event loop! + # The local event loop waits for the result to come back. + # It is also necessary for the execution of forwarded channel + # operations. + + set ::tres "" + testthread send -async $tid { + after 500 + catch {s} res; # This runs the script, 's' was defined at (*) + testthread send -async $mid [list set ::tres $res] + } + vwait ::tres + # Remove test thread, and return the captured result. + + tcltest::threadReap + return $::tres +} + +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### + +test iortrans.tf-3.2 {chan finalize, for close} -match glob -body { + set res {} + proc foo {args} {track; oninit; return {}} + note [set c [chan push [tempchan] foo]] + note [inthread $c { + close $c + # Close the deleted the channel. + file channels rt* + } c] + # Channel destruction does not kill handler command! + note [info command foo] + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{initialize rt* {read write}} file* {finalize rt*} {} foo} +test iortrans.tf-3.3 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code error 5} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg]; note $msg + # Channel is gone despite error. + note [file channels rt*] + notes + } c] + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}} +test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -match glob -body { + set res {} + proc foo {args} {track; oninit; error FOO} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO} +test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -match glob -body { + set res {} + proc foo {args} {track; oninit; return SOMETHING} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}} +test iortrans.tf-3.6 {chan finalize, for close, break, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code 3} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ + -constraints {testchannel testthread} + + +test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code 4} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -code 777 BANG} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -match glob -body { + set res {} + proc foo {args} {track; oninit; return -level 5 -code 777 BANG} + note [set c [chan push [tempchan] foo]] + notes [inthread $c { + note [catch {close $c} msg opt]; note $msg; noteOpts $opt + notes + } c] + rename foo {} + set res +} -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method read + +test iortrans.tf-4.1 {chan read, transform call and return} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return snarf + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [read $c 10] + close $c + notes + } c] + tempdone + rename foo {} + set res +} -constraints {testchannel testthread} -result {{read rt* {test data +}} snarf} + +test iortrans.tf-4.2 {chan read, for non-readable channel} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track; note MUST_NOT_HAPPEN + } + set c [chan push [tempchan w] foo] + notes [inthread $c { + note [catch {[read $c 2]} msg]; note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -constraints {testchannel testthread} -result {1 {channel "file*" wasn't opened for reading}} +test iortrans.tf-4.3 {chan read, error return} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code error BOOM! + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {read $c 2} msg]; note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 BOOM!} \ + -constraints {testchannel testthread} +test iortrans.tf-4.4 {chan read, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code break BOOM! + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {read $c 2} msg]; note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-4.5 {chan read, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code continue BOOM! + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {read $c 2} msg]; note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-4.6 {chan read, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -code 777 BOOM! + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {read $c 2} msg]; note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code*} \ + -constraints {testchannel testthread} + +test iortrans.tf-4.7 {chan read, level is squashed} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal; track + return -level 55 -code 777 BOOM! + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {read $c 2} msg opt]; note $msg; noteOpts $opt + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method write + +test iortrans.tf-5.1 {chan write, regular write} -match glob -body { + set res {} + proc foo {args} { oninit; onfinal; track ; return transformresult } + set c [chan push [tempchan] foo] + inthread $c { + puts -nonewline $c snarf; flush $c + close $c + } c + note [tempview] + tempdone + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rt* snarf} transformresult} +test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -match glob -body { + set res {} + proc foo {args} { oninit; onfinal; track ; return {} } + set c [chan push [tempchan] foo] + inthread $c { + puts -nonewline $c snarfsnarfsnarf; flush $c + close $c + } c + note [tempview];# This has to show the original data, as nothing was written + tempdone + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{write rt* snarfsnarfsnarf} {test data}} +test iortrans.tf-5.3 {chan write, failed write} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code error FAIL!} + set c [chan push [tempchan] foo] + notes [inthread $c { + puts -nonewline $c snarfsnarfsnarf + note [catch {flush $c} msg] + note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{write rt* snarfsnarfsnarf} 1 FAIL!} +test iortrans.tf-5.4 {chan write, non-writable channel} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return} + set c [chan push [tempchan r] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {1 {channel "file*" wasn't opened for writing}} +test iortrans.tf-5.5 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code error BOOM!} + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} +test iortrans.tf-5.6 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; error BOOM!} + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + + +test iortrans.tf-5.7 {chan write, failed write, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code break BOOM!} + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-5.8 {chan write, failed write, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code continue BOOM!} + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + close $c + notes + } c] + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-5.9 {chan write, failed write, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!} + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg] + note $msg + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code*} \ + -constraints {testchannel testthread} +test iortrans.tf-5.10 {chan write, failed write, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!} + set c [chan push [tempchan] foo] + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf; flush $c} msg opt] + note $msg + noteOpts $opt + close $c + notes + } c] + tempdone + rename foo {} + set res +} -result {{write rt* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \ + -constraints {testchannel testthread} + + +# --- === *** ########################### +# method limit?, drain (via read) + +test iortrans.tf-6.1 {chan read, read limits} -match glob -body { + set res {} + proc foo {args} { + oninit limit?; onfinal; track ; onread + return 6 + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [read $c 10] + } c] + tempdone + rename foo {} + set res +} -result {{limit? rt*} {read rt* {test d}} {limit? rt*} {read rt* {ata +}} {limit? rt*} @@} -constraints {testchannel testthread} +test iortrans.tf-6.2 {chan read, read transform drain on eof} -match glob -body { + set res {} + proc foo {args} { + oninit drain; onfinal; track ; onread ; ondrain + return + } + set c [chan push [tempchan] foo] + notes [inthread $c { + note [read $c] + note [close $c] + } c] + tempdone + rename foo {} + set res +} -result {{read rt* {test data +}} {drain rt*} @<> {}} -constraints {testchannel testthread} + +# --- === *** ########################### +# method clear (via puts, seek) + +test iortrans.tf-7.1 {chan write, write clears read buffers} -match glob -body { + set res {} + proc foo {args} { + oninit clear; onfinal; track ; onclear + return transformresult + } + set c [chan push [tempchan] foo] + inthread $c { + puts -nonewline $c snarf; flush $c + close $c + } c + tempdone + rename foo {} + set res +} -result {{clear rt*} {write rt* snarf}} -constraints {testchannel testthread} +test iortrans.tf-7.2 {seek clears read buffers} -match glob -body { + set res {} + proc foo {args} { + oninit clear; onfinal; track + return + } + set c [chan push [tempchan] foo] + inthread $c { + seek $c 2 + close $c + } c + tempdone + rename foo {} + set res +} -result {{clear rt*}} -constraints {testchannel testthread} +test iortrans.tf-7.3 {clear, any result is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit clear; onfinal; track + return -code error "X" + } + set c [chan push [tempchan] foo] + inthread $c { + seek $c 2 + close $c + } c + tempdone + rename foo {} + set res +} -result {{clear rt*}} -constraints {testchannel testthread} + +# --- === *** ########################### +# method flush (via seek, close) + +test iortrans-8.1 {seek flushes write buffers, ignores data} -match glob -body { + set res {} + proc foo {args} { + oninit flush; onfinal; track + return X + } + set c [chan push [tempchan] foo] + notes [inthread $c { + # Flush, no writing + seek $c 2 + # The close flushes again, this modifies the file! + note | ; note [close $c] ; note | + # NOTE: The flush generated by the close is recorded + # immediately, the other note's here are defered until after + # the thread is done. This changes the order of the result a + # bit from the non-threaded case (The first | moves one to the + # right). This is an artifact of the 'inthread' framework, not + # of the transformation itself. + notes + } c] + note [tempview] + tempdone + rename foo {} + set res +} -result {{flush rt*} {flush rt*} | {} | {teXt data}} -constraints {testchannel testthread} + +test iortrans-8.2 {close flushes write buffers, writes data} -match glob -body { + set res {} + proc foo {args} { + oninit flush; track ; onfinal + return .flushed. + } + set c [chan push [tempchan] foo] + inthread $c { + close $c + } c + note [tempview] + tempdone + rename foo {} + set res +} -result {{flush rt*} {finalize rt*} .flushed.} -constraints {testchannel testthread} + + +# --- === *** ########################### +# method watch - removed from TIP (rev 1.12+) + +# --- === *** ########################### +# method event - removed from TIP (rev 1.12+) + +# --- === *** ########################### +# 'Pull the rug' tests. Create channel in a thread A, move to other +# thread B, destroy the origin thread (A) before or during access from +# B. Must not crash, must return proper errors. + +test iortrans.tf-11.0 {origin thread of moved transform gone} -match glob -body { + + #puts <<$tcltest::mainThread>>main + set tida [testthread create];#puts <<$tida>> + set tidb [testthread create];#puts <<$tidb>> + + # Set up channel in thread + testthread send $tida $helperscript + set chan [testthread send $tida { + proc foo {args} {oninit clear drain flush limit? read write; onfinal; track; return} + set chan [chan push [tempchan] foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd thread, transform goes with it. + testthread send $tida [list testchannel cut $chan] + testthread send $tidb [list testchannel splice $chan] + + # Kill origin thread, then access channel from 2nd thread. + testthread send -async $tida {testthread exit} + after 100 + + set res {} + lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg + lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg + lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg + lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg + tcltest::threadReap + set res + # The 'tell' is ok, as it passed through the transform to the base + # channel without invoking the transform handler. + +} -constraints {testchannel testthread} \ + -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} + +test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -match glob -body { + + #puts <<$tcltest::mainThread>>main + set tida [testthread create];#puts <<$tida>> + set tidb [testthread create];#puts <<$tidb>> + + # Set up channel in thread + set chan [testthread send $tida $helperscript] + set chan [testthread send $tida { + proc foo {args} { + oninit clear drain flush limit? read write; onfinal; track; + # destroy thread during channel access + testthread exit + return} + set chan [chan push [tempchan] foo] + fconfigure $chan -buffering none + set chan + }] + + # Move channel to 2nd thread, transform goes with it. + testthread send $tida [list testchannel cut $chan] + testthread send $tidb [list testchannel splice $chan] + + # Run access from thread B, wait for response from A (A is not + # using event loop at this point, so the event pile up in the + # queue. + + testthread send $tidb [list set chan $chan] + testthread send $tidb [list set mid $tcltest::mainThread] + testthread send -async $tidb { + # wait a bit, give the main thread the time to start its event + # loop to wait for the response from B + after 2000 + catch { puts $chan shoo } res + testthread send -async $mid [list set ::res $res] + } + vwait ::res + + tcltest::threadReap + set res +} -constraints {testchannel testthread} \ + -result {Owner lost} + +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### + +rename track {} +cleanupTests +return diff --git a/unix/Makefile.in b/unix/Makefile.in index d7d6f82..bf35876 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.236 2008/06/01 00:02:05 dkf Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.237 2008/06/06 19:46:42 andreas_kupries Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -283,7 +283,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ - tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ + tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ @@ -395,6 +395,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ $(GENERIC_DIR)/tclIORChan.c \ + $(GENERIC_DIR)/tclIORTrans.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ @@ -1073,6 +1074,9 @@ tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c $(FSHDR) tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c $(IOHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c +tclIORTrans.o: $(GENERIC_DIR)/tclIORTrans.c $(IOHDR) + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORTrans.c + tclLink.o: $(GENERIC_DIR)/tclLink.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c diff --git a/win/Makefile.in b/win/Makefile.in index 13d3109..5e32d59 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -4,7 +4,7 @@ # "./configure", which is a configuration script generated by the "autoconf" # program (constructs like "@foo@" will get replaced in the actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.131 2008/06/01 02:44:54 mistachkin Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.132 2008/06/06 19:46:42 andreas_kupries Exp $ VERSION = @TCL_VERSION@ @@ -241,6 +241,7 @@ GENERIC_OBJS = \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ tclIORChan.$(OBJEXT) \ + tclIORTrans.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ diff --git a/win/makefile.vc b/win/makefile.vc index b33da87..27dc974 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -13,7 +13,7 @@ # Copyright (c) 2003-2008 Pat Thoyts. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.182 2008/06/01 02:44:54 mistachkin Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.183 2008/06/06 19:46:42 andreas_kupries Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -278,6 +278,7 @@ TCLOBJS = \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ $(TMP_DIR)\tclIORChan.obj \ + $(TMP_DIR)\tclIORTrans.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ |