diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | generic/tclIORChan.c | 3099 |
2 files changed, 1499 insertions, 1612 deletions
@@ -1,8 +1,14 @@ +2005-10-19 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> + + * generic/tclIORChan.c: General cleanup, removing checks that are + unnecessary due to the general contracts of other functions in the + core, converting to using ANSI declarations, etc. Note that nearly + the whole file has changed, but it is often just cosmetic. + 2005-10-19 Miguel Sofer <msofer@users.sf.net> - * generic/tclExecute.c (INST_DICT_APPEND, INST_DICT_LAPPEND): - fixed faulty peephole optimisation that can cause crashes - [Bug 1331475] + * generic/tclExecute.c (INST_DICT_APPEND, INST_DICT_LAPPEND): fixed + faulty peephole optimisation that can cause crashes [Bug 1331475] 2005-10-18 Don Porter <dgp@users.sourceforge.net> diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index a3012c0..064c5cc 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -1,21 +1,21 @@ -/* +/* * tclIORChan.c -- * - * This file contains the implementation of Tcl's generic - * channel reflection code, which allows the implementation - * of Tcl channels in Tcl code. + * This file contains the implementation of Tcl's generic channel + * reflection code, which allows the implementation of Tcl channels in + * Tcl code. * - * Parts of this file are based on code contributed by - * Jean-Claude Wippler. + * Parts of this file are based on code contributed by Jean-Claude + * Wippler. * - * See TIP #219 for the specification of this functionality. + * See TIP #219 for the specification of this functionality. * * Copyright (c) 2004-2005 ActiveState, a divison of Sophos * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIORChan.c,v 1.6 2005/10/05 17:44:58 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIORChan.c,v 1.7 2005/10/19 13:59:01 dkf Exp $ */ #include <tclInt.h> @@ -23,77 +23,56 @@ #include <assert.h> #ifndef EINVAL -#define EINVAL 9 +#define EINVAL 9 #endif #ifndef EOK -#define EOK 0 +#define EOK 0 #endif /* * Signatures of all functions used in the C layer of the reflection. */ -/* Required */ -static int RcClose _ANSI_ARGS_((ClientData clientData, - Tcl_Interp *interp)); - -/* Required, "read" is optional despite this. */ -static int RcInput _ANSI_ARGS_((ClientData clientData, - char *buf, int toRead, int *errorCodePtr)); - -/* Required, "write" is optional despite this. */ -static int RcOutput _ANSI_ARGS_((ClientData clientData, - CONST char *buf, int toWrite, int *errorCodePtr)); - -/* Required */ -static void RcWatch _ANSI_ARGS_((ClientData clientData, int mask)); - -/* NULL'able - "blocking", is optional */ -static int RcBlock _ANSI_ARGS_((ClientData clientData, - int mode)); - -/* NULL'able - "seek", is optional */ -static Tcl_WideInt RcSeekWide _ANSI_ARGS_((ClientData clientData, - Tcl_WideInt offset, - int mode, int *errorCodePtr)); - -static int RcSeek _ANSI_ARGS_((ClientData clientData, - long offset, int mode, int *errorCodePtr)); - -/* NULL'able - "cget" / "cgetall", are optional */ -static int RcGetOption _ANSI_ARGS_((ClientData clientData, - Tcl_Interp* interp, - CONST char *optionName, - Tcl_DString *dsPtr)); - -/* NULL'able - "configure", is optional */ -static int RcSetOption _ANSI_ARGS_((ClientData clientData, - Tcl_Interp* interp, - CONST char *optionName, - CONST char *newValue)); - +static int ReflectClose(ClientData clientData, + Tcl_Interp *interp); +static int ReflectInput(ClientData clientData, char *buf, + int toRead, int *errorCodePtr); +static int ReflectOutput(ClientData clientData, CONST char *buf, + int toWrite, int *errorCodePtr); +static void ReflectWatch(ClientData clientData, int mask); +static int ReflectBlock(ClientData clientData, int mode); +static Tcl_WideInt ReflectSeekWide(ClientData clientData, + Tcl_WideInt offset, int mode, int *errorCodePtr); +static int ReflectSeek(ClientData clientData, long offset, + int mode, int *errorCodePtr); +static int ReflectGetOption(ClientData clientData, + Tcl_Interp *interp, CONST char *optionName, + Tcl_DString *dsPtr); +static int ReflectSetOption(ClientData clientData, + Tcl_Interp *interp, CONST char *optionName, + CONST char *newValue); /* - * The C layer channel type/driver definition used by the reflection. - * This is a version 3 structure. + * The C layer channel type/driver definition used by the reflection. This is + * a version 3 structure. */ static Tcl_ChannelType tclRChannelType = { - "tclrchannel", /* Type name. */ - TCL_CHANNEL_VERSION_3, - RcClose, /* Close channel, clean instance data */ - RcInput, /* Handle read request */ - RcOutput, /* Handle write request */ - RcSeek, /* Move location of access point. NULL'able */ - RcSetOption, /* Set options. NULL'able */ - RcGetOption, /* Get options. NULL'able */ - RcWatch, /* Initialize notifier */ - NULL, /* Get OS handle from the channel. NULL'able */ - NULL, /* No close2 support. NULL'able */ - RcBlock, /* Set blocking/nonblocking. NULL'able */ - NULL, /* Flush channel. Not used by core. NULL'able */ - NULL, /* Handle events. NULL'able */ - RcSeekWide /* Move access point (64 bit). NULL'able */ + "tclrchannel", /* Type name. */ + TCL_CHANNEL_VERSION_3, + ReflectClose, /* Close channel, clean instance data */ + ReflectInput, /* Handle read request */ + ReflectOutput, /* Handle write request */ + ReflectSeek, /* Move location of access point. NULL'able */ + ReflectSetOption, /* Set options. NULL'able */ + ReflectGetOption, /* Get options. NULL'able */ + ReflectWatch, /* Initialize notifier */ + NULL, /* Get OS handle from the channel. NULL'able */ + NULL, /* No close2 support. NULL'able */ + ReflectBlock, /* Set blocking/nonblocking. NULL'able */ + NULL, /* Flush channel. Not used by core. NULL'able */ + NULL, /* Handle events. NULL'able */ + ReflectSeekWide /* Move access point (64 bit). NULL'able */ }; /* @@ -101,75 +80,69 @@ static Tcl_ChannelType tclRChannelType = { */ typedef struct { - Tcl_Channel chan; /* Back reference to generic channel structure. - */ - Tcl_Interp* interp; /* Reference to the interpreter containing the - * Tcl level part of the channel. */ + Tcl_Channel chan; /* Back reference to generic channel + * structure. */ + Tcl_Interp *interp; /* Reference to the interpreter containing the + * Tcl level part of the channel. */ #ifdef TCL_THREADS - Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ + Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif - /* See [==] as well. - * Storage for the command prefix and the additional words required - * for the invocation of methods in the command handler. - * - * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] - * cmd ... pfx | method chan | detail1 detail2 - * ~~~~ CT ~~~ ~~ CT ~~ - * - * CT = Belongs to the 'Command handler Thread'. - */ - - int argc; /* Number of preallocated words - 2 */ - Tcl_Obj** argv; /* Preallocated array for calling the handler. - * args [0] is placeholder for cmd word. - * Followed by the arguments in the prefix, - * plus 4 placeholders for method, channel, - * and at most two varying (method specific) - * words. - */ - - int methods; /* Bitmask of supported methods */ - - /* ---------------------------------------- */ - - /* NOTE (9): Should we have predefined shared literals - * NOTE (9): for the method names ? - */ - - /* ---------------------------------------- */ - - int mode; /* Mask of R/W mode */ - int interest; /* Mask of events the channel is interested in. */ - - /* Note regarding the usage of timers. - * - * Most channel implementations need a timer in the - * C level to ensure that data in buffers is flushed - * out through the generation of fake file events. - * - * See 'rechan', 'memchan', etc. - * - * Here this is _not_ required. Interest in events is - * posted to the Tcl level via 'watch'. And posting of - * events is possible from the Tcl level as well, via - * 'chan postevent'. This means that the generation of - * all events, fake or not, timer based or not, is - * completely in the hands of the Tcl level. Therefore - * no timer here. - */ - -} ReflectingChannel; + /* See [==] as well. + * Storage for the command prefix and the additional words required for + * the invocation of methods in the command handler. + * + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + * ~~~~ CT ~~~ ~~ CT ~~ + * + * CT = Belongs to the 'Command handler Thread'. + */ + + int argc; /* Number of preallocated words - 2 */ + Tcl_Obj **argv; /* Preallocated array for calling the handler. + * args[0] is placeholder for cmd word. + * Followed by the arguments in the prefix, + * plus 4 placeholders for method, channel, + * and at most two varying (method specific) + * words. */ + int methods; /* Bitmask of supported methods */ + + /* + * NOTE (9): Should we have predefined shared literals for the method + * names? + */ + + int mode; /* Mask of R/W mode */ + int interest; /* Mask of events the channel is interested + * in. */ + + /* + * Note regarding the usage of timers. + * + * Most channel implementations need a timer in the C level to ensure that + * data in buffers is flushed out through the generation of fake file + * events. + * + * See 'rechan', 'memchan', etc. + * + * Here this is _not_ required. Interest in events is posted to the Tcl + * level via 'watch'. And posting of events is possible from the Tcl level + * as well, via 'chan postevent'. This means that the generation of all + * events, fake or not, timer based or not, is completely in the hands of + * the Tcl level. Therefore no timer here. + */ +} ReflectedChannel; /* * Event literals. ================================================== */ static CONST char *eventOptions[] = { - "read", "write", (char *) NULL + "read", "write", NULL }; typedef enum { - EVENT_READ, EVENT_WRITE + EVENT_READ, EVENT_WRITE } EventOption; /* @@ -177,49 +150,51 @@ typedef enum { */ static CONST char *methodNames[] = { - "blocking", /* OPT */ - "cget", /* OPT \/ Together or none */ - "cgetall", /* OPT /\ of these two */ - "configure", /* OPT */ - "finalize", /* */ - "initialize", /* */ - "read", /* OPT */ - "seek", /* OPT */ - "watch", /* */ - "write", /* OPT */ - (char *) NULL + "blocking", /* OPT */ + "cget", /* OPT \/ Together or none */ + "cgetall", /* OPT /\ of these two */ + "configure", /* OPT */ + "finalize", /* */ + "initialize", /* */ + "read", /* OPT */ + "seek", /* OPT */ + "watch", /* */ + "write", /* OPT */ + NULL }; typedef enum { - METH_BLOCKING, - METH_CGET, - METH_CGETALL, - METH_CONFIGURE, - METH_FINAL, - METH_INIT, - METH_READ, - METH_SEEK, - METH_WATCH, - METH_WRITE, + METH_BLOCKING, + METH_CGET, + METH_CGETALL, + METH_CONFIGURE, + METH_FINAL, + METH_INIT, + METH_READ, + METH_SEEK, + METH_WATCH, + METH_WRITE, } MethodName; #define FLAG(m) (1 << (m)) -#define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH)) -#define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \ - FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL)) +#define REQUIRED_METHODS \ + (FLAG(METH_INIT) | FLAG(METH_FINAL) | FLAG(METH_WATCH)) +#define NULLABLE_METHODS \ + (FLAG(METH_BLOCKING) | FLAG(METH_SEEK) | \ + FLAG(METH_CONFIGURE) | FLAG(METH_CGET) | FLAG(METH_CGETALL)) -#define RANDW (TCL_READABLE|TCL_WRITABLE) +#define RANDW \ + (TCL_READABLE | TCL_WRITABLE) -#define IMPLIES(a,b) ((!(a)) || (b)) +#define IMPLIES(a,b) ((!(a)) || (b)) #define NEGIMPL(a,b) -#define HAS(x,f) (x & FLAG(f)) - +#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'. + * We are here essentially creating a very specific implementation of 'thread + * send'. */ /* @@ -227,216 +202,211 @@ typedef enum { */ typedef enum { - RcOpClose, - RcOpInput, - RcOpOutput, - RcOpSeek, - RcOpWatch, - RcOpBlock, - RcOpSetOpt, - RcOpGetOpt, - RcOpGetOptAll -} RcOperation; + ForwardedClose, + ForwardedInput, + ForwardedOutput, + ForwardedSeek, + ForwardedWatch, + ForwardedBlock, + ForwardedSetOpt, + ForwardedGetOpt, + ForwardedGetOptAll +} ForwardedOperation; /* - * Event used to forward driver invocations to the thread actually - * managing the channel. We cannot construct the command to execute - * and forward that. Because then it will contain a mixture of - * Tcl_Obj's belonging to both the command handler thread (CT), and - * the thread managing the channel (MT), executed in CT. Tcl_Obj's are - * not allowed to cross thread boundaries. So we forward an operation - * code, the argument details ,and reference to results. The command - * is assembled in the CT and belongs fully to that thread. No sharing - * problems. + * 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 RcForwardParamBase { - int code; /* O: Ok/Fail of the cmd handler */ - char* msg; /* O: Error message for handler failure */ - int vol; /* O: True - msg is allocated, False - msg is static */ -} RcForwardParamBase; +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. + * 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.) */ -typedef struct RcForwardParamClose { - RcForwardParamBase b; -} RcForwardParamClose; - -typedef struct RcForwardParamInput { - RcForwardParamBase b; - char* buf; /* O: Where to store the read bytes */ - int toRead; /* I: #bytes to read, - * O: #bytes actually read */ -} RcForwardParamInput; - -typedef struct RcForwardParamOutput { - RcForwardParamBase b; - CONST char* buf; /* I: Where the bytes to write come from */ - int toWrite; /* I: #bytes to write, - * O: #bytes actually written */ -} RcForwardParamOutput; - -typedef struct RcForwardParamSeek { - RcForwardParamBase b; - int seekMode; /* I: How to seek */ - Tcl_WideInt offset; /* I: Where to seek, - * O: New location */ -} RcForwardParamSeek; - -typedef struct RcForwardParamWatch { - RcForwardParamBase b; - int mask; /* I: What events to watch for */ -} RcForwardParamWatch; - -typedef struct RcForwardParamBlock { - RcForwardParamBase b; - int nonblocking; /* I: What mode to activate */ -} RcForwardParamBlock; - -typedef struct RcForwardParamSetOpt { - RcForwardParamBase b; - CONST char* name; /* Name of option to set */ - CONST char* value; /* Value to set */ -} RcForwardParamSetOpt; - -typedef struct RcForwardParamGetOpt { - RcForwardParamBase b; - CONST char* name; /* Name of option to get, maybe NULL */ - Tcl_DString* value; /* Result */ -} RcForwardParamGetOpt; +struct ForwardParamInput { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + char *buf; /* O: Where to store the read bytes */ + int toRead; /* I: #bytes to read, + * O: #bytes actually read */ +}; +struct ForwardParamOutput { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + CONST char *buf; /* I: Where the bytes to write come from */ + int toWrite; /* I: #bytes to write, + * O: #bytes actually written */ +}; +struct ForwardParamSeek { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + int seekMode; /* I: How to seek */ + Tcl_WideInt offset; /* I: Where to seek, + * O: New location */ +}; +struct ForwardParamWatch { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + int mask; /* I: What events to watch for */ +}; +struct ForwardParamBlock { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + int nonblocking; /* I: What mode to activate */ +}; +struct ForwardParamSetOpt { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + CONST char *name; /* Name of option to set */ + CONST char *value; /* Value to set */ +}; +struct ForwardParamGetOpt { + ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ + CONST char *name; /* Name of option to get, maybe NULL */ + Tcl_DString *value; /* Result */ +}; /* - * General event structure, with reference to - * operation specific data. + * Now join all these together in a single union for convenience. */ -typedef struct RcForwardingEvent { - Tcl_Event event; /* Basic event data, has to be first item */ - struct RcForwardingResult* resultPtr; - - RcOperation op; /* Forwarded driver operation */ - ReflectingChannel* rcPtr; /* Channel instance */ - CONST RcForwardParamBase* param; /* Arguments, a RcForwardParamXXX pointer */ -} RcForwardingEvent; +typedef union ForwardParam { + ForwardParamBase base; + struct ForwardParamInput input; + struct ForwardParamOutput output; + struct ForwardParamSeek seek; + struct ForwardParamWatch watch; + struct ForwardParamBlock block; + struct ForwardParamSetOpt setOpt; + struct ForwardParamGetOpt getOpt; +} ForwardParam; /* - * 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. + * Forward declaration. */ -typedef struct RcForwardingResult { - - Tcl_ThreadId src; /* Originating thread. */ - Tcl_ThreadId dst; /* Thread the op was forwarded to. */ - Tcl_Condition done; /* Condition variable the forwarder blocks on. */ - int result; /* TCL_OK or TCL_ERROR */ - - struct RcForwardingEvent* evPtr; /* Event the result belongs to. */ - - struct RcForwardingResult* prevPtr; /* Links into the list of pending */ - struct RcForwardingResult* nextPtr; /* forwarded results. */ - -} RcForwardingResult; +typedef struct ForwardingResult ForwardingResult; /* - * List of forwarded operations which have not completed yet, plus the - * mutex to protect the access to this process global list. + * General event structure, with reference to operation specific data. */ -static RcForwardingResult* forwardList = (RcForwardingResult*) NULL; -TCL_DECLARE_MUTEX (rcForwardMutex) +typedef struct ForwardingEvent { + Tcl_Event event; /* Basic event data, has to be first item */ + ForwardingResult *resultPtr; + ForwardedOperation op; /* Forwarded driver operation */ + ReflectedChannel *rcPtr; /* Channel instance */ + CONST ForwardParam *param; /* Arguments, a ForwardParamXXX pointer */ +} ForwardingEvent; /* - * Function containing the generic code executing a forward, and - * wrapper macros for the actual operations we wish to forward. + * 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. */ -static void -RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op, - Tcl_ThreadId dst, CONST VOID* param)); +struct ForwardingResult { + Tcl_ThreadId src; /* Originating thread. */ + Tcl_ThreadId dst; /* 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. */ +}; /* - * The event function executed by the thread receiving a forwarding - * event. Executes the appropriate function and collects the result, - * if any. + * List of forwarded operations which have not completed yet, plus the mutex + * to protect the access to this process global list. */ -static int -RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask)); +static ForwardingResult *forwardList = NULL; +TCL_DECLARE_MUTEX(rcForwardMutex) /* - * Helpers which intercept when threads are going away, and clean up - * after pending forwarding events. Different actions depending on - * which thread went away, originator (src), or receiver (dst). + * 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 -RcSrcExitProc _ANSI_ARGS_ ((ClientData clientData)); - -static void -RcDstExitProc _ANSI_ARGS_ ((ClientData clientData)); - -#define RcFreeReceivedError(pb) \ - if ((pb).vol) {ckfree ((pb).msg);} - -#define RcPassReceivedErrorInterp(i,pb) \ - if ((i)) {Tcl_SetChannelErrorInterp ((i), Tcl_NewStringObj ((pb).msg,-1));} \ - RcFreeReceivedError (pb) - -#define RcPassReceivedError(c,pb) \ - Tcl_SetChannelError ((c), Tcl_NewStringObj ((pb).msg,-1)); \ - RcFreeReceivedError (pb) - -#define RcForwardSetStaticError(p,emsg) \ - (p)->code = TCL_ERROR; (p)->vol = 0; (p)->msg = (char*) (emsg); - -#define RcForwardSetDynError(p,emsg) \ - (p)->code = TCL_ERROR; (p)->vol = 1; (p)->msg = (char*) (emsg); - -static void -RcForwardSetObjError _ANSI_ARGS_ ((RcForwardParamBase* p, - Tcl_Obj* obj)); +static void ForwardOpToOwnerThread(ReflectedChannel *rcPtr, + ForwardedOperation op, CONST VOID *param); +static int ForwardProc(Tcl_Event *evPtr, int mask); +static void SrcExitProc(ClientData clientData); +static void DstExitProc(ClientData clientData); +#define FreeReceivedError(p) \ + if ((p)->base.mustFree) { \ + ckfree((p)->base.msgStr); \ + } +#define PassReceivedErrorInterp(i,pb) \ + if ((i) != NULL) { \ + Tcl_Obj *preiTmpObj; \ + TclNewStringObj(preiTmpObj, (p)->base.msgStr, -1); \ + Tcl_SetChannelErrorInterp((i), preiTmpObj); \ + } \ + FreeReceivedError(p) +#define PassReceivedError(c,p) \ + { \ + Tcl_Obj *preTmpObj; \ + TclNewStringObj(preTmpObj, (p)->base.msgStr, -1); \ + Tcl_SetChannelError((c), preTmpObj); \ + 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); #endif /* TCL_THREADS */ -#define RcSetChannelErrorStr(c,msg) \ - Tcl_SetChannelError ((c), Tcl_NewStringObj ((msg),-1)) - -static Tcl_Obj* RcErrorMarshall _ANSI_ARGS_ ((Tcl_Interp *interp)); -static void RcErrorReturn _ANSI_ARGS_ ((Tcl_Interp* interp, Tcl_Obj* msg)); +#define SetChannelErrorStr(c,msgStr) \ + Tcl_SetChannelError((c), Tcl_NewStringObj((msgStr), -1)) +static Tcl_Obj * MarshallError(Tcl_Interp *interp); +static void UnmarshallErrorResult(Tcl_Interp *interp, + Tcl_Obj *msgObj); - /* * Static functions for this file: */ -static int RcEncodeEventMask _ANSI_ARGS_((Tcl_Interp* interp, - CONST char* objName, Tcl_Obj* obj, - int* mask)); - -static Tcl_Obj* RcDecodeEventMask _ANSI_ARGS_ ((int mask)); - -static ReflectingChannel* RcNew _ANSI_ARGS_ ((Tcl_Interp* interp, - Tcl_Obj* cmdpfxObj, int mode, - Tcl_Obj* id)); - -static Tcl_Obj* RcNewHandle _ANSI_ARGS_ ((void)); +static int EncodeEventMask(Tcl_Interp *interp, + CONST char *objName, Tcl_Obj *obj, int *mask); +static Tcl_Obj * DecodeEventMask(int mask); +static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp, + Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj); +static Tcl_Obj * NextHandle(void); +static void FreeReflectedChannel(ReflectedChannel *rcPtr); +static int InvokeTclMethod(ReflectedChannel *rcPtr, + CONST char *method, Tcl_Obj *argOneObj, + Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr, + int flags); -static void RcFree _ANSI_ARGS_ ((ReflectingChannel* rcPtr)); - -static void -RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr, - CONST char* method, Tcl_Obj* argone, Tcl_Obj* argtwo, - int* result, Tcl_Obj** resultObj, int capture)); - -#define NO_CAPTURE (0) -#define DO_CAPTURE (1) +#define INVOKE_NO_CAPTURE 0x01 /* * Global constant strings (messages). ================== @@ -445,15 +415,14 @@ RcInvokeTclMethod _ANSI_ARGS_((ReflectingChannel* rcPtr, * list-quoting to keep the words of the message together. See also [x]. */ -static CONST char* msg_read_unsup = "{read not supported by Tcl driver}"; -static CONST char* msg_read_toomuch = "{read delivered more than requested}"; -static CONST char* msg_write_unsup = "{write not supported by Tcl driver}"; -static CONST char* msg_write_toomuch = "{write wrote more than requested}"; -static CONST char* msg_seek_beforestart = "{Tried to seek before origin}"; - +static CONST char *msg_read_unsup = "{read not supported by Tcl driver}"; +static CONST char *msg_read_toomuch = "{read delivered more than requested}"; +static CONST char *msg_write_unsup = "{write not supported by Tcl driver}"; +static CONST char *msg_write_toomuch = "{write wrote more than requested}"; +static CONST char *msg_seek_beforestart = "{Tried to seek before origin}"; #ifdef TCL_THREADS -static CONST char* msg_send_originlost = "{Origin thread lost}"; -static CONST char* msg_send_dstlost = "{Destination thread lost}"; +static CONST char *msg_send_originlost = "{Origin thread lost}"; +static CONST char *msg_send_dstlost = "{Destination thread lost}"; #endif /* TCL_THREADS */ /* @@ -465,12 +434,12 @@ static CONST char* msg_send_dstlost = "{Destination thread lost}"; * * TclChanCreateObjCmd -- * - * This procedure is invoked to process the "chan create" Tcl - * command. See the user documentation for details on what it does. + * This function is invoked to process the "chan create" Tcl command. + * See the user documentation for details on what it does. * * Results: - * A standard Tcl result. - * The handle of the new channel is placed in the interp result. + * A standard Tcl result. The handle of the new channel is placed in the + * interp result. * * Side effects: * Creates a new channel. @@ -479,223 +448,226 @@ static CONST char* msg_send_dstlost = "{Destination thread lost}"; */ int -TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp* interp; - int objc; - Tcl_Obj* CONST* objv; +TclChanCreateObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { - ReflectingChannel* rcPtr; /* Instance data of the new channel */ - Tcl_Obj* rcId; /* Handle of the new channel */ - int mode; /* R/W mode of new channel. Has to - * match abilities of handler commands */ - Tcl_Obj* cmdObj; /* Command prefix, list of words */ - Tcl_Obj* cmdNameObj; /* Command name */ - Tcl_Channel chan; /* Token for the new channel */ - Tcl_Obj* modeObj; /* mode in obj form for method call */ - int listc; /* Result of 'initialize', and of */ - Tcl_Obj** listv; /* its sublist in the 2nd element */ - int methIndex; /* Encoded method name */ - int res; /* Result code for 'initialize' */ - Tcl_Obj* resObj; /* Result data for 'initialize' */ - int methods; /* Bitmask for supported methods. */ - Channel* chanPtr; /* 'chan' resolved to internal struct. */ - - /* Syntax: chan create MODE CMDPREFIX + ReflectedChannel *rcPtr; /* Instance data of the new channel */ + Tcl_Obj *rcId; /* Handle of the new channel */ + int mode; /* R/W mode of new channel. Has to match + * abilities of handler commands */ + Tcl_Obj *cmdObj; /* Command prefix, list of words */ + Tcl_Obj *cmdNameObj; /* Command name */ + Tcl_Channel chan; /* Token for the new channel */ + Tcl_Obj *modeObj; /* mode in obj form for method call */ + int listc; /* Result of 'initialize', and of */ + Tcl_Obj **listv; /* its sublist in the 2nd element */ + int methIndex; /* Encoded method name */ + int result; /* Result code for 'initialize' */ + Tcl_Obj *resObj; /* Result data for 'initialize' */ + int methods; /* Bitmask for supported methods. */ + Channel *chanPtr; /* 'chan' resolved to internal struct. */ + + /* + * Syntax: chan create MODE CMDPREFIX * [0] [1] [2] [3] * * Actually: rCreate MODE CMDPREFIX * [0] [1] [2] */ -#define MODE (1) -#define CMD (2) +#define MODE (1) +#define CMD (2) - /* Number of arguments ... */ + /* + * Number of arguments... + */ if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix"); + Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix"); return TCL_ERROR; } - /* First argument is a list of modes. Allowed entries are "read", - * "write". Expect at least one list element. Abbreviations are - * ok. + /* + * First argument is a list of modes. Allowed entries are "read", "write". + * Expect at least one list element. Abbreviations are ok. */ - modeObj = objv [MODE]; - if (RcEncodeEventMask (interp, "mode", objv [MODE], &mode) != TCL_OK) { - return TCL_ERROR; + modeObj = objv[MODE]; + if (EncodeEventMask(interp, "mode", objv[MODE], &mode) != TCL_OK) { + return TCL_ERROR; } - /* Second argument is command prefix, i.e. list of words, first - * word is name of handler command, other words are fixed - * arguments. Run 'initialize' method to get the list of supported - * methods. Validate this. + /* + * 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]; + cmdObj = objv[CMD]; - /* Basic check that the command prefix truly is a list. */ + /* + * Basic check that the command prefix truly is a list. + */ if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) { - return TCL_ERROR; + return TCL_ERROR; } - /* Now create the channel. + /* + * Now create the channel. */ - rcId = RcNewHandle (); - rcPtr = RcNew (interp, cmdObj, mode, rcId); - chan = Tcl_CreateChannel (&tclRChannelType, - Tcl_GetString (rcId), - rcPtr, mode); + rcId = NextHandle(); + rcPtr = NewReflectedChannel(interp, cmdObj, mode, rcId); + chan = Tcl_CreateChannel(&tclRChannelType, TclGetString(rcId), rcPtr, + mode); rcPtr->chan = chan; - chanPtr = (Channel*) chan; - - /* Invoke 'initialize' and validate that the handler - * is present and ok. Squash the channel if not. - */ + chanPtr = (Channel *) chan; - /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that + /* + * Invoke 'initialize' and validate that the handler is present and ok. + * Squash the channel if not. + * + * Note: The conversion of 'mode' back into a Tcl_Obj ensures that * 'initialize' is invoked with canonical mode names, and no - * abbreviations. Using modeObj directly could feed abbreviations - * into the handler, and the handler is not specified to handle - * such. + * abbreviations. Using modeObj directly could feed abbreviations into the + * handler, and the handler is not specified to handle such. */ - modeObj = RcDecodeEventMask (mode); - RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL, - &res, &resObj, NO_CAPTURE); - Tcl_DecrRefCount (modeObj); + modeObj = DecodeEventMask(mode); + result = InvokeTclMethod(rcPtr, "initialize", modeObj, NULL, &resObj, + INVOKE_NO_CAPTURE); + Tcl_DecrRefCount(modeObj); + if (result != TCL_OK) { + Tcl_Obj *err = Tcl_NewStringObj("Initialize failure: ", -1); - if (res != TCL_OK) { - Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); - - Tcl_AppendObjToObj(err,resObj); - Tcl_SetObjResult (interp,err); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_AppendObjToObj(err, resObj); + Tcl_SetObjResult(interp, err); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ goto error; } - /* Verify the result. + /* + * Verify the result. * - List, of method names. Convert to mask. * Check for non-optionals through the mask. * Compare open mode against optional r/w. */ - Tcl_AppendResult (interp, "Initialize failure: ", (char*) NULL); + Tcl_AppendResult(interp, "Initialize failure: ", NULL); - if (Tcl_ListObjGetElements (interp, resObj, - &listc, &listv) != TCL_OK) { - /* The function above replaces my prefix in case of an error, - * so more work for us to get the prefix back into the error - * message + if (Tcl_ListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) { + /* + * The function above replaces my prefix in case of an error, so more + * work for us to get the prefix back into the error message */ - Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); + Tcl_Obj *err = Tcl_NewStringObj("Initialize failure: ", -1); - Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); - Tcl_SetObjResult (interp,err); + Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); + Tcl_SetObjResult(interp, err); goto error; } methods = 0; while (listc > 0) { - if (Tcl_GetIndexFromObj (interp, listv [listc-1], - methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { - Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); + if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, + "method", TCL_EXACT, &methIndex) != TCL_OK) { + Tcl_Obj *err = Tcl_NewStringObj("Initialize failure: ", -1); - Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); - Tcl_SetObjResult (interp,err); + Tcl_AppendObjToObj(err, Tcl_GetObjResult(interp)); + Tcl_SetObjResult(interp, err); goto error; } - methods |= FLAG (methIndex); - listc --; + methods |= FLAG(methIndex); + listc--; } if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { - Tcl_AppendResult (interp, "Not all required methods supported", - (char*) NULL); + Tcl_AppendResult(interp, "Not all required methods supported", NULL); goto error; } - if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) { - Tcl_AppendResult (interp, "Reading not supported, but requested", - (char*) NULL); + if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { + Tcl_AppendResult(interp, "Reading not supported, but requested", NULL); goto error; } - if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) { - Tcl_AppendResult (interp, "Writing not supported, but requested", - (char*) NULL); + if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { + Tcl_AppendResult(interp, "Writing not supported, but requested", NULL); goto error; } - if (!IMPLIES (HAS(methods,METH_CGET), HAS(methods,METH_CGETALL))) { - Tcl_AppendResult (interp, "'cgetall' not supported, but should be, as 'cget' is", - (char*) NULL); + if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { + Tcl_AppendResult(interp, + "'cgetall' not supported, but should be, as 'cget' is", NULL); goto error; } - if (!IMPLIES (HAS(methods,METH_CGETALL),HAS(methods,METH_CGET))) { - Tcl_AppendResult (interp, "'cget' not supported, but should be, as 'cgetall' is", - (char*) NULL); + if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { + Tcl_AppendResult(interp, + "'cget' not supported, but should be, as 'cgetall' is", NULL); goto error; } - Tcl_ResetResult (interp); + Tcl_ResetResult(interp); - /* Everything is fine now */ + /* + * Everything is fine now. + */ rcPtr->methods = methods; if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { - /* Some of the nullable methods are not supported. We clone - * the channel type, null the associated C functions, and use - * the result as the actual channel type. + /* + * Some of the nullable methods are not supported. We clone the + * channel type, null the associated C functions, and use the result + * as the actual channel type. */ - Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType)); - if (clonePtr == (Tcl_ChannelType*) NULL) { - Tcl_Panic ("Out of memory in Tcl_RcCreate"); - } + Tcl_ChannelType *clonePtr = (Tcl_ChannelType *) + ckalloc(sizeof(Tcl_ChannelType)); - memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType)); + memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); - if (!(methods & FLAG (METH_CONFIGURE))) { - clonePtr->setOptionProc = NULL; + if (!(methods & FLAG(METH_CONFIGURE))) { + clonePtr->setOptionProc = NULL; } - if ( - !(methods & FLAG (METH_CGET)) && - !(methods & FLAG (METH_CGETALL)) - ) { + if (!(methods & FLAG(METH_CGET)) && !(methods & FLAG(METH_CGETALL))) { clonePtr->getOptionProc = NULL; } - if (!(methods & FLAG (METH_BLOCKING))) { + if (!(methods & FLAG(METH_BLOCKING))) { clonePtr->blockModeProc = NULL; } - if (!(methods & FLAG (METH_SEEK))) { - clonePtr->seekProc = NULL; + if (!(methods & FLAG(METH_SEEK))) { + clonePtr->seekProc = NULL; clonePtr->wideSeekProc = NULL; } chanPtr->typePtr = clonePtr; } - Tcl_RegisterChannel (interp, chan); + Tcl_RegisterChannel(interp, chan); - /* Return handle as result of command */ + /* + * Return handle as result of command. + */ - Tcl_SetObjResult (interp, rcId); + Tcl_SetObjResult(interp, rcId); return TCL_OK; error: - /* Signal to RcClose to not call 'finalize' */ + /* + * Signal to ReflectClose to not call 'finalize'. + */ rcPtr->methods = 0; - Tcl_Close (interp, chan); + Tcl_Close(interp, chan); return TCL_ERROR; #undef MODE @@ -707,190 +679,198 @@ TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv) * * TclChanPostEventObjCmd -- * - * This procedure is invoked to process the "chan postevent" - * Tcl command. See the user documentation for details on what it does. + * This function is invoked to process the "chan postevent" Tcl command. + * See the user documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: - * Posts events to a reflected channel, invokes event handlers. - * The latter implies that arbitrary side effects are possible. + * Posts events to a reflected channel, invokes event handlers. The + * latter implies that arbitrary side effects are possible. * *---------------------------------------------------------------------- */ int -TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv) - ClientData clientData; - Tcl_Interp* interp; - int objc; - Tcl_Obj* CONST* objv; +TclChanPostEventObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *CONST *objv) { - /* Syntax: chan postevent CHANNEL EVENTSPEC + /* + * Syntax: chan postevent CHANNEL EVENTSPEC * [0] [1] [2] [3] * * Actually: rPostevent CHANNEL EVENTSPEC * [0] [1] [2] * - * where EVENTSPEC = {read write ...} (Abbreviations allowed as well. + * where EVENTSPEC = {read write ...} (Abbreviations allowed as well). */ -#define CHAN (1) -#define EVENT (2) +#define CHAN (1) +#define EVENT (2) - CONST char* chanId; /* Tcl level channel handle */ - Tcl_Channel chan; /* Channel associated to the handle */ - Tcl_ChannelType* chanTypePtr; /* Its associated driver structure */ - ReflectingChannel* rcPtr; /* Associated instance data */ - int mode; /* Dummy, r|w mode of the channel */ - int events; /* Mask of events to post */ + CONST char *chanId; /* Tcl level channel handle */ + Tcl_Channel chan; /* Channel associated to the handle */ + Tcl_ChannelType *chanTypePtr; + /* Its associated driver structure */ + ReflectedChannel *rcPtr; /* Associated instance data */ + int mode; /* Dummy, r|w mode of the channel */ + int events; /* Mask of events to post */ - /* Number of arguments ... */ + /* + * Number of arguments... + */ if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec"); + Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec"); return TCL_ERROR; } - /* First argument is a channel, a reflected channel, and the call - * of this command is done from the interp defining the channel - * handler cmd. + /* + * First argument is a channel, a reflected channel, and the call of this + * command is done from the interp defining the channel handler cmd. */ - chanId = Tcl_GetString (objv [CHAN]); - chan = Tcl_GetChannel(interp, chanId, &mode); + chanId = TclGetString(objv[CHAN]); + chan = Tcl_GetChannel(interp, chanId, &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; + if (chan == NULL) { + return TCL_ERROR; } - chanTypePtr = Tcl_GetChannelType (chan); + chanTypePtr = Tcl_GetChannelType(chan); - /* We use a function referenced by the channel type as our cookie - * to detect calls to non-reflecting channels. The channel type - * itself is not suitable, as it might not be the static - * definition in this file, but a clone thereof. And while we have - * reserved the name of the type nothing in the core checks - * against violation, so someone else might have created a channel - * type using our name, clashing with ourselves. + /* + * We use a function referenced by the channel type as our cookie to + * detect calls to non-reflecting channels. The channel type itself is not + * suitable, as it might not be the static definition in this file, but a + * clone thereof. And while we have reserved the name of the type nothing + * in the core checks against violation, so someone else might have + * created a channel type using our name, clashing with ourselves. */ - if (chanTypePtr->watchProc != &RcWatch) { - Tcl_AppendResult(interp, "channel \"", chanId, - "\" is not a reflected channel", - (char *) NULL); + if (chanTypePtr->watchProc != &ReflectWatch) { + Tcl_AppendResult(interp, "channel \"", chanId, + "\" is not a reflected channel", NULL); return TCL_ERROR; } - rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan); + rcPtr = (ReflectedChannel *) Tcl_GetChannelInstanceData(chan); if (rcPtr->interp != interp) { - Tcl_AppendResult(interp, "postevent for channel \"", chanId, - "\" called from outside interpreter", - (char *) NULL); + Tcl_AppendResult(interp, "postevent for channel \"", chanId, + "\" called from outside interpreter", NULL); return TCL_ERROR; } - /* Second argument is a list of events. Allowed entries are - * "read", "write". Expect at least one list element. - * Abbreviations are ok. + /* + * Second argument is a list of events. Allowed entries are "read", + * "write". Expect at least one list element. Abbreviations are ok. */ - if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) { - return TCL_ERROR; + if (EncodeEventMask(interp, "event", objv[EVENT], &events) != TCL_OK) { + return TCL_ERROR; } - - /* Check that the channel is actually interested in the provided - * events. + + /* + * Check that the channel is actually interested in the provided events. */ if (events & ~rcPtr->interest) { - Tcl_AppendResult(interp, "tried to post events channel \"", chanId, - "\" is not interested in", - (char *) NULL); + Tcl_AppendResult(interp, "tried to post events channel \"", chanId, + "\" is not interested in", NULL); return TCL_ERROR; } - /* We have the channel and the events to post. + /* + * We have the channel and the events to post. */ - Tcl_NotifyChannel (chan, events); + Tcl_NotifyChannel(chan, events); - /* Squash interp results left by the event script. + /* + * Squash interp results left by the event script. */ - Tcl_ResetResult (interp); + Tcl_ResetResult(interp); return TCL_OK; #undef CHAN #undef EVENT } +/* + * Channel error message marshalling utilities. + */ static Tcl_Obj* -RcErrorMarshall (interp) - Tcl_Interp *interp; +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. + /* + * 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_Obj *returnOpt = Tcl_GetReturnOptions(interp, TCL_ERROR); + + /* + * => returnOpt.refCount == 0. We can append directly. */ - Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp)); + Tcl_ListObjAppendElement(NULL, returnOpt, Tcl_GetObjResult(interp)); return returnOpt; } static void -RcErrorReturn (interp, msg) - Tcl_Interp *interp; - Tcl_Obj *msg; +UnmarshallErrorResult( + Tcl_Interp *interp, + Tcl_Obj *msgObj) { - int res; - int lc; - Tcl_Obj** lv; - int explicitResult; - int numOptions; + int lc; + Tcl_Obj **lv; + int explicitResult; + int numOptions; - /* Process the caught message. + /* + * Process the caught message. * * Syntax = (option value)... ?message? * - * Bad syntax causes a panic. Because the other side uses + * Bad syntax causes a panic. This is OK because the other side uses * Tcl_GetReturnOptions and list construction functions to marshall the - * information. + * information; if we panic here, something has gone badly wrong already. */ - res = Tcl_ListObjGetElements (interp, msg, &lc, &lv); - if (res != TCL_OK) { - Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result"); + if (Tcl_ListObjGetElements(interp, msgObj, &lc, &lv) != TCL_OK) { + Tcl_Panic("TclChanCaughtErrorBypass: Bad syntax of caught result"); } - explicitResult = (1 == (lc % 2)); - numOptions = lc - explicitResult; + explicitResult = lc & 1; /* Odd number of values? */ + numOptions = lc - explicitResult; if (explicitResult) { - Tcl_SetObjResult (interp, lv [lc-1]); + Tcl_SetObjResult(interp, lv[lc-1]); } - (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv)); + (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj(numOptions, lv)); } int -TclChanCaughtErrorBypass (interp, chan) - Tcl_Interp *interp; - Tcl_Channel chan; +TclChanCaughtErrorBypass( + Tcl_Interp *interp, + Tcl_Channel chan) { - Tcl_Obj* msgc = NULL; - Tcl_Obj* msgi = NULL; - Tcl_Obj* msg = NULL; + Tcl_Obj *chanMsgObj = NULL; + Tcl_Obj *interpMsgObj = NULL; + Tcl_Obj *msgObj = NULL; - /* Get a bypassed error message from channel and/or interpreter, save the + /* + * Get a bypassed error message from channel and/or interpreter, save the * reference, then kill the returned objects, if there were any. If there * are messages in both the channel has preference. */ @@ -900,37 +880,39 @@ TclChanCaughtErrorBypass (interp, chan) } if (chan != NULL) { - Tcl_GetChannelError (chan, &msgc); + Tcl_GetChannelError(chan, &chanMsgObj); } if (interp != NULL) { - Tcl_GetChannelErrorInterp (interp, &msgi); + Tcl_GetChannelErrorInterp(interp, &interpMsgObj); } - if (msgc != NULL) { - msg = msgc; - Tcl_IncrRefCount (msg); - } else if (msgi != NULL) { - msg = msgi; - Tcl_IncrRefCount (msg); + if (chanMsgObj != NULL) { + msgObj = chanMsgObj; + } else if (interpMsgObj != NULL) { + msg = interpMsgObj; + } + if (msgObj != NULL) { + Tcl_IncrRefCount(msgObj); } - if (msgc != NULL) { - Tcl_DecrRefCount (msgc); + if (chanMsgObj != NULL) { + Tcl_DecrRefCount(chanMsgObj); } - if (msgi != NULL) { - Tcl_DecrRefCount (msgi); + if (interpMsgObj != NULL) { + Tcl_DecrRefCount(interpMsgObj); } - /* No message returned, nothing caught. + /* + * No message returned, nothing caught. */ - if (msg == NULL) { + if (msgObj == NULL) { return 0; } - RcErrorReturn (interp, msg); + UnmarshallErrorResult(interp, msgObj); - Tcl_DecrRefCount (msg); + Tcl_DecrRefCount(msgObj); return 1; } @@ -941,10 +923,10 @@ TclChanCaughtErrorBypass (interp, chan) /* *---------------------------------------------------------------------- * - * RcClose -- + * ReflectClose -- * - * This function is invoked when the channel is closed, to delete - * the driver specific instance data. + * This function is invoked when the channel is closed, to delete the + * driver specific instance data. * * Results: * A posix error. @@ -956,107 +938,106 @@ TclChanCaughtErrorBypass (interp, chan) */ static int -RcClose (clientData, interp) - ClientData clientData; - Tcl_Interp* interp; +ReflectClose( + ClientData clientData, + Tcl_Interp *interp) { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - int res; /* Result code for 'close' */ - Tcl_Obj* resObj; /* Result data for 'close' */ - - if (interp == (Tcl_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. + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + int result; /* Result code for 'close' */ + Tcl_Obj *resObj; /* Result data for 'close' */ + + 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: Have a thread delete handler for the origin - * thread. Use this to clean up the structure! - */ - -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * THREADED => Forward this to the origin thread + * + * Note: Have a thread delete handler for the origin thread. Use this + * to clean up the structure! */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamClose p; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p); - res = p.b.code; + ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); + result = p.base.code; - /* RcFree is done in the forwarded operation!, - * in the other thread. rcPtr here is gone! + /* + * FreeReflectedChannel is done in the forwarded operation!, in + * the other thread. rcPtr here is gone! */ - if (res != TCL_OK) { - RcFreeReceivedError (p.b); + if (result != TCL_OK) { + FreeReceivedError(&p); } - } else { -#endif - RcFree (rcPtr); -#ifdef TCL_THREADS + return EOK; } #endif + + FreeReflectedChannel(rcPtr); return EOK; } - /* -------- */ + /* + * -- No -- ASSERT rcPtr->methods & FLAG(METH_FINAL) + * + * A cleaned method mask here implies that the channel creation was + * aborted, and "finalize" must not be called. + */ - /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */ + if (rcPtr->methods == 0) { + FreeReflectedChannel(rcPtr); + return EOK; + } - /* A cleaned method mask here implies that the channel creation - * was aborted, and "finalize" must not be called. + /* + * Are we in the correct thread? */ - if (rcPtr->methods == 0) { - RcFree (rcPtr); - return EOK; - } else { #ifdef TCL_THREADS - /* Are we in the correct thread ? - */ + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamClose p; + ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p); + result = p.base.code; - RcForwardOp (rcPtr, RcOpClose, rcPtr->thread, &p); - res = p.b.code; - - /* RcFree is done in the forwarded operation!, - * in the other thread. rcPtr here is gone! - */ + /* + * FreeReflectedChannel is done in the forwarded operation!, in the + * other thread. rcPtr here is gone! + */ - if (res != TCL_OK) { - RcPassReceivedErrorInterp (interp, p.b); - } - } else { + if (result != TCL_OK) { + PassReceivedErrorInterp(interp, &p); + } + } else { #endif - RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, - &res, &resObj, DO_CAPTURE); - - if ((res != TCL_OK) && (interp != NULL)) { - Tcl_SetChannelErrorInterp (interp, resObj); - } + result = InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj, 0); + if ((result != TCL_OK) && (interp != NULL)) { + Tcl_SetChannelErrorInterp(interp, resObj); + } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_DecrRefCount(resObj); /* Remove reference we held from the + * invoke */ #ifdef TCL_THREADS - RcFree (rcPtr); - } -#endif - return (res == TCL_OK) ? EOK : EINVAL; + FreeReflectedChannel(rcPtr); } +#endif + return (result == TCL_OK) ? EOK : EINVAL; } /* *---------------------------------------------------------------------- * - * RcInput -- + * ReflectInput -- * - * This function is invoked when more data is requested from the - * channel. + * This function is invoked when more data is requested from the channel. * * Results: * The number of bytes read. @@ -1068,69 +1049,61 @@ RcClose (clientData, interp) */ static int -RcInput (clientData, buf, toRead, errorCodePtr) - ClientData clientData; - char* buf; - int toRead; - int* errorCodePtr; +ReflectInput( + ClientData clientData, + char *buf, + int toRead, + int *errorCodePtr) { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* toReadObj; - int bytec; /* Number of returned bytes */ - unsigned char* bytev; /* Array of returned bytes */ - int res; /* Result code for 'read' */ - Tcl_Obj* resObj; /* Result data for 'read' */ + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + Tcl_Obj *toReadObj; + int bytec; /* Number of returned bytes */ + unsigned char *bytev; /* Array of returned bytes */ + Tcl_Obj *resObj; /* Result data for 'read' */ - /* The following check can be done before thread redirection, - * because we are reading from an item which is readonly, i.e. - * will never change during the lifetime of the channel. + /* + * The following check can be done before thread redirection, because we + * are reading from an item which is readonly, i.e. will never change + * during the lifetime of the channel. */ - if (!(rcPtr->methods & FLAG (METH_READ))) { - RcSetChannelErrorStr (rcPtr->chan, msg_read_unsup); + if (!(rcPtr->methods & FLAG(METH_READ))) { + SetChannelErrorStr(rcPtr->chan, msg_read_unsup); *errorCodePtr = EINVAL; return -1; } -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamInput p; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - p.buf = buf; - p.toRead = toRead; + p.input.buf = buf; + p.input.toRead = toRead; - RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedInput, &p); - if (p.b.code != TCL_OK) { - RcPassReceivedError (rcPtr->chan, p.b); + if (p.base.code != TCL_OK) { + PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; } else { *errorCodePtr = EOK; } - return p.toRead; + return p.input.toRead; } #endif - /* -------- */ - - /* ASSERT: rcPtr->method & FLAG (METH_READ) */ + /* ASSERT: rcPtr->method & FLAG(METH_READ) */ /* ASSERT: rcPtr->mode & TCL_READABLE */ toReadObj = Tcl_NewIntObj(toRead); - if (toReadObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcInput"); - } - - RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - Tcl_SetChannelError (rcPtr->chan, resObj); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj, 0)!=TCL_OK) { + Tcl_SetChannelError(rcPtr->chan, resObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return -1; } @@ -1138,8 +1111,8 @@ RcInput (clientData, buf, toRead, errorCodePtr) bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); if (toRead < bytec) { - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); *errorCodePtr = EINVAL; return -1; } @@ -1147,20 +1120,19 @@ RcInput (clientData, buf, toRead, errorCodePtr) *errorCodePtr = EOK; if (bytec > 0) { - memcpy (buf, bytev, bytec); + memcpy(buf, bytev, bytec); } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ return bytec; } /* *---------------------------------------------------------------------- * - * RcOutput -- + * ReflectOutput -- * - * This function is invoked when data is writen to the - * channel. + * This function is invoked when data is writen to the channel. * * Results: * The number of bytes actually written. @@ -1172,90 +1144,81 @@ RcInput (clientData, buf, toRead, errorCodePtr) */ static int -RcOutput (clientData, buf, toWrite, errorCodePtr) - ClientData clientData; - CONST char* buf; - int toWrite; - int* errorCodePtr; +ReflectOutput( + ClientData clientData, + CONST char *buf, + int toWrite, + int *errorCodePtr) { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* bufObj; - int res; /* Result code for 'write' */ - Tcl_Obj* resObj; /* Result data for 'write' */ - int written; + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + Tcl_Obj *bufObj; + Tcl_Obj *resObj; /* Result data for 'write' */ + int written; - /* The following check can be done before thread redirection, - * because we are reading from an item which is readonly, i.e. - * will never change during the lifetime of the channel. + /* + * The following check can be done before thread redirection, because we + * are reading from an item which is readonly, i.e. will never change + * during the lifetime of the channel. */ - if (!(rcPtr->methods & FLAG (METH_WRITE))) { - RcSetChannelErrorStr (rcPtr->chan, msg_write_unsup); - *errorCodePtr = EINVAL; + if (!(rcPtr->methods & FLAG(METH_WRITE))) { + SetChannelErrorStr(rcPtr->chan, msg_write_unsup); + *errorCodePtr = EINVAL; return -1; } -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamOutput p; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - p.buf = buf; - p.toWrite = toWrite; + p.output.buf = buf; + p.output.toWrite = toWrite; - RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedOutput, &p); - if (p.b.code != TCL_OK) { - RcPassReceivedError (rcPtr->chan, p.b); - *errorCodePtr = EINVAL; - } else { - *errorCodePtr = EOK; - } + if (p.base.code != TCL_OK) { + PassReceivedError(rcPtr->chan, &p); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } - return p.toWrite; + return p.output.toWrite; } #endif - /* -------- */ - - /* ASSERT: rcPtr->method & FLAG (METH_WRITE) */ + /* ASSERT: rcPtr->method & FLAG(METH_WRITE) */ /* ASSERT: rcPtr->mode & TCL_WRITABLE */ - - bufObj = Tcl_NewByteArrayObj((unsigned char*) buf, toWrite); - if (bufObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcOutput"); - } - RcInvokeTclMethod (rcPtr, "write", bufObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - Tcl_SetChannelError (rcPtr->chan, resObj); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + bufObj = Tcl_NewByteArrayObj((unsigned char *) buf, toWrite); + if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj, 0) != TCL_OK) { + Tcl_SetChannelError(rcPtr->chan, resObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return -1; } - res = Tcl_GetIntFromObj (rcPtr->interp, resObj, &written); - if (res != TCL_OK) { - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp)); + if (Tcl_GetIntFromObj(rcPtr->interp, resObj, &written) != TCL_OK) { + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); *errorCodePtr = EINVAL; return -1; } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ if ((written == 0) || (toWrite < written)) { - /* The handler claims to have written more than it was given. - * That is bad. Note that the I/O core would crash if we were - * to return this information, trying to write -nnn bytes in - * the next iteration. + /* + * The handler claims to have written more than it was given. That is + * bad. Note that the I/O core would crash if we were to return this + * information, trying to write -nnn bytes in the next iteration. */ - RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch); + SetChannelErrorStr(rcPtr->chan, msg_write_toomuch); *errorCodePtr = EINVAL; return -1; } @@ -1267,10 +1230,9 @@ RcOutput (clientData, buf, toWrite, errorCodePtr) /* *---------------------------------------------------------------------- * - * RcSeekWide / RcSeek -- + * ReflectSeekWide / ReflectSeek -- * - * This function is invoked when the user wishes to seek on - * the channel. + * This function is invoked when the user wishes to seek on the channel. * * Results: * The new location of the access point. @@ -1282,84 +1244,66 @@ RcOutput (clientData, buf, toWrite, errorCodePtr) */ static Tcl_WideInt -RcSeekWide (clientData, offset, seekMode, errorCodePtr) - ClientData clientData; - Tcl_WideInt offset; - int seekMode; - int* errorCodePtr; +ReflectSeekWide( + ClientData clientData, + Tcl_WideInt offset, + int seekMode, + int *errorCodePtr) { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* offObj; - Tcl_Obj* baseObj; - int res; /* Result code for 'seek' */ - Tcl_Obj* resObj; /* Result data for 'seek' */ - Tcl_WideInt newLoc; + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + Tcl_Obj *offObj; + Tcl_Obj *baseObj; + Tcl_Obj *resObj; /* Result for 'seek' */ + Tcl_WideInt newLoc; -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamSeek p; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - p.seekMode = seekMode; - p.offset = offset; + p.seek.seekMode = seekMode; + p.seek.offset = offset; - RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedSeek, &p); - if (p.b.code != TCL_OK) { - RcPassReceivedError (rcPtr->chan, p.b); + if (p.base.code != TCL_OK) { + PassReceivedError(rcPtr->chan, &p); *errorCodePtr = EINVAL; } else { *errorCodePtr = EOK; } - return p.offset; + return p.seek.offset; } #endif - /* -------- */ - - /* ASSERT: rcPtr->method & FLAG (METH_SEEK) */ + /* ASSERT: rcPtr->method & FLAG(METH_SEEK) */ offObj = Tcl_NewWideIntObj(offset); - if (offObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSeekWide"); - } - - baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? - "start" : - ((seekMode == SEEK_CUR) ? - "current" : - "end"), -1); - - if (baseObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSeekWide"); - } - - RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - Tcl_SetChannelError (rcPtr->chan, resObj); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + baseObj = Tcl_NewStringObj((seekMode == SEEK_SET) ? "start" : + ((seekMode == SEEK_CUR) ? "current" : "end"), -1); + if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj, 0)!=TCL_OK) { + Tcl_SetChannelError(rcPtr->chan, resObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ *errorCodePtr = EINVAL; return -1; } - res = Tcl_GetWideIntFromObj (rcPtr->interp, resObj, &newLoc); - if (res != TCL_OK) { - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - Tcl_SetChannelError (rcPtr->chan, RcErrorMarshall (rcPtr->interp)); + if (Tcl_GetWideIntFromObj(rcPtr->interp, resObj, &newLoc) != TCL_OK) { + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + Tcl_SetChannelError(rcPtr->chan, MarshallError(rcPtr->interp)); *errorCodePtr = EINVAL; return -1; } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ - if (newLoc < Tcl_LongAsWide (0)) { - RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart); - *errorCodePtr = EINVAL; + if (newLoc < Tcl_LongAsWide(0)) { + SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart); + *errorCodePtr = EINVAL; return -1; } @@ -1368,29 +1312,30 @@ RcSeekWide (clientData, offset, seekMode, errorCodePtr) } static int -RcSeek (clientData, offset, seekMode, errorCodePtr) - ClientData clientData; - long offset; - int seekMode; - int* errorCodePtr; +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 o this we have to - * implement it, a dummy is not enough. We simply delegate the call - * to the wide routine. - */ - - return (int) RcSeekWide (clientData, Tcl_LongAsWide (offset), - seekMode, 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); } /* *---------------------------------------------------------------------- * - * RcWatch -- + * ReflectWatch -- * - * This function is invoked to tell the channel what events - * the I/O system is interested in. + * This function is invoked to tell the channel what events the I/O + * system is interested in. * * Results: * None. @@ -1402,62 +1347,66 @@ RcSeek (clientData, offset, seekMode, errorCodePtr) */ static void -RcWatch (clientData, mask) - ClientData clientData; - int mask; +ReflectWatch( + ClientData clientData, + int mask) { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* maskObj; + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + Tcl_Obj *maskObj; - /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */ + /* ASSERT rcPtr->methods & FLAG(METH_WATCH) */ - /* We restrict the interest to what the channel can support - * IOW there will never be write events for a channel which is - * not writable. Analoguous for read events. + /* + * We restrict the interest to what the channel can support. IOW there + * will never be write events for a channel which is not writable. + * Analoguously for read events and non-readable channels. */ - mask = mask & rcPtr->mode; + mask &= rcPtr->mode; if (mask == rcPtr->interest) { - /* Same old, same old, why should we do something ? */ - return; + /* + * Same old, same old, why should we do something? + */ + + return; } rcPtr->interest = mask; -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamWatch p; - - p.mask = mask; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p); + p.watch.mask = mask; + ForwardOpToOwnerThread(rcPtr, ForwardedWatch, &p); - /* Any failure from the forward is ignored. We have no place to - * put this. + /* + * Any failure from the forward is ignored. We have no place to put + * this. */ + return; } #endif - /* -------- */ - - maskObj = RcDecodeEventMask (mask); - RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL, - NULL, NULL, NO_CAPTURE); - Tcl_DecrRefCount (maskObj); + maskObj = DecodeEventMask(mask); + (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL, + INVOKE_NO_CAPTURE); + Tcl_DecrRefCount(maskObj); } /* *---------------------------------------------------------------------- * - * RcBlock -- + * ReflectBlock -- * - * This function is invoked to tell the channel which blocking - * behaviour is required of it. + * This function is invoked to tell the channel which blocking behaviour + * is required of it. * * Results: * A posix error number. @@ -1469,60 +1418,54 @@ RcWatch (clientData, mask) */ static int -RcBlock (clientData, nonblocking) - ClientData clientData; - int nonblocking; +ReflectBlock( + ClientData clientData, + int nonblocking) { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* blockObj; - int res; /* Result code for 'blocking' */ - Tcl_Obj* resObj; /* Result data for 'blocking' */ + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + Tcl_Obj *blockObj; + int errorNum; /* EINVAL or EOK (success). */ + Tcl_Obj *resObj; /* Result data for 'blocking' */ -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamBlock p; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - p.nonblocking = nonblocking; + p.block.nonblocking = nonblocking; - RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p); + ForwardOpToOwnerThread(rcPtr, ForwardedBlock, &p); - if (p.b.code != TCL_OK) { - RcPassReceivedError (rcPtr->chan, p.b); + if (p.base.code != TCL_OK) { + PassReceivedError(rcPtr->chan, &p); return EINVAL; - } else { - return EOK; } + + return EOK; } #endif - /* -------- */ - blockObj = Tcl_NewBooleanObj(!nonblocking); - if (blockObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcBlock"); - } - RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - Tcl_SetChannelError (rcPtr->chan, resObj); - res = EINVAL; + if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj, + 0) != TCL_OK) { + Tcl_SetChannelError(rcPtr->chan, resObj); + errorNum = EINVAL; } else { - res = EOK; + errorNum = EOK; } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - return res; + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + return errorNum; } /* *---------------------------------------------------------------------- * - * RcSetOption -- + * ReflectSetOption -- * * This function is invoked to configure a channel option. * @@ -1536,70 +1479,58 @@ RcBlock (clientData, nonblocking) */ static int -RcSetOption (clientData, interp, optionName, newValue) - 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 */ +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 */ { - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* optionObj; - Tcl_Obj* valueObj; - int res; /* Result code for 'configure' */ - Tcl_Obj* resObj; /* Result data for 'configure' */ + ReflectedChannel *rcPtr = (ReflectedChannel *) clientData; + Tcl_Obj *optionObj; + Tcl_Obj *valueObj; + int result; /* Result code for 'configure' */ + Tcl_Obj *resObj; /* Result data for 'configure' */ -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - RcForwardParamSetOpt p; - - p.name = optionName; - p.value = newValue; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + ForwardParam p; - RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p); + p.setOpt.name = optionName; + p.setOpt.value = newValue; - if (p.b.code != TCL_OK) { - Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); + ForwardOpToOwnerThread(rcPtr, ForwardedSetOpt, &p); - RcErrorReturn (interp, err); + if (p.base.code != TCL_OK) { + Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1); - Tcl_DecrRefCount (err); - if (p.b.vol) {ckfree (p.b.msg);} + UnmarshallErrorResult(interp, err); + Tcl_DecrRefCount(err); + FreeReceivedError(&p); } - return p.b.code; + return p.base.code; } #endif - /* -------- */ - - optionObj = Tcl_NewStringObj(optionName,-1); - if (optionObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSetOption"); - } - - valueObj = Tcl_NewStringObj(newValue,-1); - if (valueObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSetOption"); - } - - RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcErrorReturn (interp, resObj); - } + optionObj = Tcl_NewStringObj(optionName, -1); + valueObj = Tcl_NewStringObj(newValue, -1); + result = InvokeTclMethod(rcPtr, "configure",optionObj,valueObj, &resObj,0); + if (result != TCL_OK) { + UnmarshallErrorResult(interp, resObj); + } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - return res; + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + return result; } /* *---------------------------------------------------------------------- * - * RcGetOption -- + * ReflectGetOption -- * * This function is invoked to retrieve all or a channel option. * @@ -1613,135 +1544,130 @@ RcSetOption (clientData, interp, optionName, newValue) */ static int -RcGetOption (clientData, interp, optionName, dsPtr) - 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 */ +ReflectGetOption( + ClientData clientData, /* Channel to query */ + Tcl_Interp *interp, /* Interpreter to leave error messages in */ + CONST char *optionName, /* Name of reuqested option */ + Tcl_DString *dsPtr) /* String to place the result into */ { - /* This code is special. It has regular passing of Tcl result, and - * errors. The bypass functions are not required. + /* + * This code is special. It has regular passing of Tcl result, and errors. + * The bypass functions are not required. */ - ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; - Tcl_Obj* optionObj; - int res; /* Result code for 'configure' */ - Tcl_Obj* resObj; /* Result data for 'configure' */ - int listc; - Tcl_Obj** listv; - const char* method; + ReflectedChannel *rcPtr = (ReflectedChannel*) clientData; + Tcl_Obj *optionObj; + Tcl_Obj *resObj; /* Result data for 'configure' */ + int listc; + Tcl_Obj **listv; + const char *method; -#ifdef TCL_THREADS - /* Are we in the correct thread ? + /* + * Are we in the correct thread? */ - if (rcPtr->thread != Tcl_GetCurrentThread ()) { - int opcode; - RcForwardParamGetOpt p; +#ifdef TCL_THREADS + if (rcPtr->thread != Tcl_GetCurrentThread()) { + int opcode; + ForwardParam p; - p.name = optionName; - p.value = dsPtr; + p.getOpt.name = optionName; + p.getOpt.value = dsPtr; - if (optionName == (char*) NULL) { - opcode = RcOpGetOptAll; + if (optionName == NULL) { + opcode = ForwardedGetOptAll; } else { - opcode = RcOpGetOpt; + opcode = ForwardedGetOpt; } - RcForwardOp (rcPtr, opcode, rcPtr->thread, &p); - - if (p.b.code != TCL_OK) { - Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); + ForwardOpToOwnerThread(rcPtr, opcode, &p); - RcErrorReturn (interp, err); + if (p.base.code != TCL_OK) { + Tcl_Obj *err = Tcl_NewStringObj(p.base.msgStr, -1); - Tcl_DecrRefCount (err); - if (p.b.vol) {ckfree (p.b.msg);} + UnmarshallErrorResult(interp, err); + Tcl_DecrRefCount(err); + FreeReceivedError(&p); } - return p.b.code; + return p.base.code; } #endif - /* -------- */ + if (optionName == NULL) { + /* + * Retrieve all options. + */ - if (optionName == (char*) NULL) { - /* Retrieve all options. */ - method = "cgetall"; + method = "cgetall"; optionObj = NULL; } else { - /* Retrieve the value of one option */ - - method = "cget"; - optionObj = Tcl_NewStringObj(optionName,-1); - if (optionObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcGetOption"); - } - } + /* + * Retrieve the value of one option. + */ - RcInvokeTclMethod (rcPtr, method, optionObj, NULL, - &res, &resObj, DO_CAPTURE); + method = "cget"; + optionObj = Tcl_NewStringObj(optionName, -1); + } - if (res != TCL_OK) { - RcErrorReturn (interp, resObj); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - return res; + if (InvokeTclMethod(rcPtr, method, optionObj, NULL, &resObj, 0)!=TCL_OK) { + UnmarshallErrorResult(interp, resObj); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + return TCL_ERROR; } - /* The result has to go into the 'dsPtr' for propagation to the - * caller of the driver. + /* + * The result has to go into the 'dsPtr' for propagation to the caller of + * the driver. */ if (optionObj != NULL) { - Tcl_DStringAppend (dsPtr, Tcl_GetString (resObj), -1); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - return res; + Tcl_DStringAppend(dsPtr, TclGetString(resObj), -1); + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + return TCL_OK; } - /* Extract the list and append each item as element. + /* + * Extract the list and append each item as element. */ - /* NOTE (4): If we extract the string rep we can assume a - * NOTE (4): properly quoted string. Together with a separating - * NOTE (4): space this way of simply appending the whole string - * NOTE (4): rep might be faster. It also doesn't check if the - * NOTE (4): result is a valid list. Nor that the list has an - * NOTE (4): even number elements. - * NOTE (4): --- + /* + * NOTE (4): If we extract the string rep we can assume a properly quoted + * string. Together with a separating space this way of simply appending + * the whole string rep might be faster. It also doesn't check if the + * result is a valid list. Nor that the list has an even number elements. */ - res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); - - if (res != TCL_OK) { - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - return res; + if (Tcl_ListObjGetElements(interp, resObj, &listc, &listv) != TCL_OK) { + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + return TCL_ERROR; } if ((listc % 2) == 1) { - /* Odd number of elements is wrong. + /* + * Odd number of elements is wrong. */ + Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_ResetResult(interp); TclObjPrintf(NULL, objPtr, "Expected list with even number of " - "elements, got %d element%s instead", listc, + "elements, got %d element%s instead", listc, (listc == 1 ? "" : "s")); Tcl_SetObjResult(interp, objPtr); - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ return TCL_ERROR; - } - - - { - int len; - char* str = Tcl_GetStringFromObj (resObj, &len); + } else { + int len; + char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { - Tcl_DStringAppend (dsPtr, " ", 1); - Tcl_DStringAppend (dsPtr, str, len); + Tcl_DStringAppend(dsPtr, " ", 1); + Tcl_DStringAppend(dsPtr, str, len); } + Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ + return TCL_OK; } - Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ - return res; } /* @@ -1751,58 +1677,60 @@ RcGetOption (clientData, interp, optionName, dsPtr) /* *---------------------------------------------------------------------- * - * RcEncodeEventMask -- + * EncodeEventMask -- * * This function takes a list of event items and constructs the - * equivalent internal bitmask. The list has to contain at - * least one element. Elements are "read", "write", or any unique - * abbreviation thereof. Note that the bitmask is not changed if - * problems are encountered. + * equivalent internal bitmask. The list has to contain at least one + * element. Elements are "read", "write", or any unique abbreviation + * thereof. Note that the bitmask is not changed if problems are + * encountered. * * Results: - * A standard Tcl error code. A bitmask where TCL_READABLE - * and/or TCL_WRITABLE can be set. + * A standard Tcl error code. A bitmask where TCL_READABLE and/or + * TCL_WRITABLE can be set. * * Side effects: - * May shimmer 'obj' to a list representation. May place an - * error message into the interp result. + * May shimmer 'obj' to a list representation. May place an error message + * into the interp result. * *---------------------------------------------------------------------- */ static int -RcEncodeEventMask (interp, objName, obj, mask) - Tcl_Interp* interp; - CONST char* objName; - Tcl_Obj* obj; - int* mask; +EncodeEventMask( + Tcl_Interp *interp, + CONST char *objName, + Tcl_Obj *obj, + int *mask) { - int events; /* Mask of events to post */ - int listc; /* #elements in eventspec list */ - Tcl_Obj** listv; /* Elements of eventspec list */ - int evIndex; /* Id of event for an element of the - * eventspec list */ + int events; /* Mask of events to post */ + int listc; /* #elements in eventspec list */ + Tcl_Obj **listv; /* Elements of eventspec list */ + int evIndex; /* Id of event for an element of the eventspec + * list. */ - if (Tcl_ListObjGetElements (interp, obj, - &listc, &listv) != TCL_OK) { - return TCL_ERROR; + if (Tcl_ListObjGetElements(interp, obj, &listc, &listv) != TCL_OK) { + return TCL_ERROR; } if (listc < 1) { - Tcl_AppendResult(interp, "bad ", objName, " list: is empty", - (char *) NULL); + Tcl_AppendResult(interp, "bad ", objName, " list: is empty", NULL); return TCL_ERROR; } events = 0; while (listc > 0) { - if (Tcl_GetIndexFromObj (interp, listv [listc-1], - eventOptions, objName, 0, &evIndex) != TCL_OK) { + if (Tcl_GetIndexFromObj(interp, listv[listc-1], eventOptions, + objName, 0, &evIndex) != TCL_OK) { return TCL_ERROR; } switch (evIndex) { - case EVENT_READ: events |= TCL_READABLE; break; - case EVENT_WRITE: events |= TCL_WRITABLE; break; + case EVENT_READ: + events |= TCL_READABLE; + break; + case EVENT_WRITE: + events |= TCL_WRITABLE; + break; } listc --; } @@ -1814,14 +1742,14 @@ RcEncodeEventMask (interp, objName, obj, mask) /* *---------------------------------------------------------------------- * - * RcDecodeEventMask -- + * DecodeEventMask -- * - * This function takes an internal bitmask of events and - * constructs the equivalent list of event items. + * 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. + * 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. @@ -1829,31 +1757,40 @@ RcEncodeEventMask (interp, objName, obj, mask) *---------------------------------------------------------------------- */ -static Tcl_Obj* -RcDecodeEventMask (mask) - int mask; +static Tcl_Obj * +DecodeEventMask( + int mask) { - Tcl_Obj* evObj = Tcl_NewStringObj (((mask & RANDW) == RANDW) ? - "read write" : - ((mask & TCL_READABLE) ? - "read" : - ((mask & TCL_WRITABLE) ? - "write" : "")), -1); - if (evObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcDecodeEventMask"); + 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; } - Tcl_IncrRefCount (evObj); + evObj = Tcl_NewStringObj(eventStr, -1); + Tcl_IncrRefCount(evObj); return evObj; } /* *---------------------------------------------------------------------- * - * RcNew -- + * NewReflectedChannel -- * - * This function is invoked to allocate and initialize the - * instance data of a new reflected channel. + * This function is invoked to allocate and initialize the instance data + * of a new reflected channel. * * Results: * A heap-allocated channel instance. @@ -1864,42 +1801,44 @@ RcDecodeEventMask (mask) *---------------------------------------------------------------------- */ -static ReflectingChannel* -RcNew (interp, cmdpfxObj, mode, id) - Tcl_Interp* interp; - Tcl_Obj* cmdpfxObj; - int mode; - Tcl_Obj* id; +static ReflectedChannel * +NewReflectedChannel( + Tcl_Interp *interp, + Tcl_Obj *cmdpfxObj, + int mode, + Tcl_Obj *handleObj) { - ReflectingChannel* rcPtr; - int listc; - Tcl_Obj** listv; - Tcl_Obj* word; - int i; + ReflectedChannel *rcPtr; + int listc; + Tcl_Obj **listv; + int i; - rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel)); + rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel)); - /* rcPtr->chan : Assigned by caller. Dummy data here. */ - /* rcPtr->methods : Assigned by caller. Dummy data here. */ + /* rcPtr->chan: Assigned by caller. Dummy data here. */ + /* rcPtr->methods: Assigned by caller. Dummy data here. */ - rcPtr->chan = (Tcl_Channel) NULL; - rcPtr->methods = 0; - rcPtr->interp = interp; + rcPtr->chan = NULL; + rcPtr->methods = 0; + rcPtr->interp = interp; #ifdef TCL_THREADS - rcPtr->thread = Tcl_GetCurrentThread (); + rcPtr->thread = Tcl_GetCurrentThread(); #endif - rcPtr->mode = mode; - rcPtr->interest = 0; /* Initially no interest registered */ + rcPtr->mode = mode; + rcPtr->interest = 0; /* Initially no interest registered */ - /* Method placeholder */ + /* + * Method placeholder. + */ /* ASSERT: cmdpfxObj is a Tcl List */ - Tcl_ListObjGetElements (interp, cmdpfxObj, &listc, &listv); + 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. + /* + * 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] @@ -1907,284 +1846,299 @@ RcNew (interp, cmdpfxObj, mode, id) */ rcPtr->argc = listc + 2; - rcPtr->argv = (Tcl_Obj**) ckalloc (sizeof (Tcl_Obj*) * (listc+4)); + rcPtr->argv = (Tcl_Obj**) ckalloc(sizeof(Tcl_Obj*) * (listc+4)); + + /* + * Duplicate object references. + */ - for (i = 0; i < listc ; i++) { - word = rcPtr->argv [i] = listv [i]; - Tcl_IncrRefCount (word); + for (i=0; i<listc ; i++) { + Tcl_Obj *word = rcPtr->argv[i] = listv[i]; + Tcl_IncrRefCount(word); } - i++; /* Skip placeholder for method */ + i++; /* Skip placeholder for method */ + + rcPtr->argv[i] = handleObj; + Tcl_IncrRefCount(handleObj); - rcPtr->argv [i] = id ; Tcl_IncrRefCount (id); + /* + * The next two objects are kept empty, varying arguments. + */ - /* The next two objects are kept empty, varying arguments */ + /* + * Initialization complete. + */ - /* Initialization complete */ return rcPtr; } /* *---------------------------------------------------------------------- * - * RcNewHandle -- + * NextHandle -- * - * This function is invoked to generate a channel handle for - * a new reflected channel. + * 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 --. + * 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. + * May allocate memory. Mutex protected critical section locks out other + * threads for a short time. * *---------------------------------------------------------------------- */ -static Tcl_Obj* -RcNewHandle () +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). + /* + * 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). */ -#ifdef TCL_THREADS - TCL_DECLARE_MUTEX (rcCounterMutex) -#endif + TCL_DECLARE_MUTEX(rcCounterMutex) static unsigned long rcCounter = 0; + Tcl_Obj *resObj; - Tcl_Obj* res = Tcl_NewObj (); - -#ifdef TCL_THREADS - Tcl_MutexLock (&rcCounterMutex); -#endif - - TclObjPrintf(NULL, res, "rc%lu", rcCounter); - rcCounter ++; + TclNewObj(resObj); + Tcl_MutexLock(&rcCounterMutex); + TclObjPrintf(NULL, resObj, "rc%lu", rcCounter); + rcCounter++; + Tcl_MutexUnlock(&rcCounterMutex); -#ifdef TCL_THREADS - Tcl_MutexUnlock (&rcCounterMutex); -#endif - - return res; + return resObj; } - static void -RcFree (rcPtr) - ReflectingChannel* rcPtr; +FreeReflectedChannel(rcPtr) + ReflectedChannel *rcPtr; { - Channel* chanPtr = (Channel*) rcPtr->chan; - int i, n; + Channel *chanPtr = (Channel *) rcPtr->chan; + int i, n; if (chanPtr->typePtr != &tclRChannelType) { - /* Delete a cloned ChannelType structure. */ - ckfree ((char*) chanPtr->typePtr); + /* + * Delete a cloned ChannelType structure. + */ + + ckfree((char*) chanPtr->typePtr); } n = rcPtr->argc - 2; - for (i = 0; i < n; i++) { - Tcl_DecrRefCount (rcPtr->argv[i]); + for (i=0; i<n; i++) { + Tcl_DecrRefCount(rcPtr->argv[i]); } - ckfree ((char*) rcPtr->argv); - ckfree ((char*) rcPtr); - return; + ckfree((char*) rcPtr->argv); + ckfree((char*) rcPtr); } /* *---------------------------------------------------------------------- * - * RcInvokeTclMethod -- + * 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. + * 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. + * Result code and data as returned by the method. * * Side effects: - * Arbitrary, as it calls upo na Tcl script. + * Arbitrary, as it calls upon a Tcl script. * *---------------------------------------------------------------------- */ -static void -RcInvokeTclMethod (rcPtr, method, argone, argtwo, result, resultObj, capture) - ReflectingChannel* rcPtr; - CONST char* method; - Tcl_Obj* argone; /* NULL'able */ - Tcl_Obj* argtwo; /* NULL'able */ - int* result; /* NULL'able */ - Tcl_Obj** resultObj; /* NULL'able */ - int capture; +static int +InvokeTclMethod( + ReflectedChannel *rcPtr; + CONST char *method; + Tcl_Obj *argOneObj; /* NULL'able */ + Tcl_Obj *argTwoObj; /* NULL'able */ + Tcl_Obj **resultObjPtr; /* NULL'able */ + int flags; { - /* Thread redirection was done by higher layers */ - /* ASSERT: Tcl_GetCurrentThread () == rcPtr->thread */ - - int cmdc; /* #words in constructed command */ - Tcl_Obj* methObj = NULL; /* Method name in object form */ - Tcl_InterpState sr; /* State of handler interp */ - int res; /* Result code of method invokation */ - Tcl_Obj* resObj = NULL; /* Result of method invokation. */ + 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. */ - /* NOTE (5): Decide impl. issue: Cache objects with method names ? - * NOTE (5): Requires TSD data as reflections can be created in - * NOTE (5): many different threads. - * NOTE (5): --- + /* + * NOTE (5): Decide impl. issue: Cache objects with method names? + * Requires TSD data as reflections can be created in many different + * threads. */ - /* Insert method into the pre-allocated area, after the command - * prefix, before the channel id. + /* + * Insert method into the pre-allocated area, after the command prefix, + * before the channel id. */ - methObj = Tcl_NewStringObj (method, -1); - if (methObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcInvokeTclMethod"); - } - Tcl_IncrRefCount (methObj); - rcPtr->argv [rcPtr->argc - 2] = methObj; + methObj = Tcl_NewStringObj(method, -1); + Tcl_IncrRefCount(methObj); + rcPtr->argv[rcPtr->argc - 2] = methObj; - /* Append the additional argument containing method specific - * details behind the channel id. If specified. + /* + * Append the additional argument containing method specific details + * behind the channel id. If specified. */ - cmdc = rcPtr->argc ; - if (argone) { - Tcl_IncrRefCount (argone); - rcPtr->argv [cmdc] = argone; - cmdc++; - } - if (argtwo) { - Tcl_IncrRefCount (argtwo); - rcPtr->argv [cmdc] = argtwo; + cmdc = rcPtr->argc; + if (argOneObj) { + Tcl_IncrRefCount(argOneObj); + rcPtr->argv[cmdc] = argOneObj; cmdc++; + if (argTwoObj) { + Tcl_IncrRefCount(argTwoObj); + rcPtr->argv[cmdc] = argTwoObj; + cmdc++; + } } - /* And run the handler ... This is done in auch a manner which - * leaves any existing state intact. + /* + * And run the handler... This is done in auch a manner which leaves any + * existing state intact. */ - sr = Tcl_SaveInterpState (rcPtr->interp, 0 /* Dummy */); - res = Tcl_EvalObjv (rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL); + sr = Tcl_SaveInterpState(rcPtr->interp, 0 /* Dummy */); + Tcl_Preserve(rcPtr->interp); + result = Tcl_EvalObjv(rcPtr->interp, cmdc, rcPtr->argv, TCL_EVAL_GLOBAL); - /* We do not try to extract the result information if the caller has no + /* + * 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 (resultObj) { - if ((res == TCL_OK) || !capture) { - /* Ok result taken as is, also if the caller requests that there + if (resultObjPtr) { + if ((result == TCL_OK) || (flags & INVOKE_NO_CAPTURE)) { + /* + * Ok result taken as is, also if the caller requests that there * is no capture. */ - resObj = Tcl_GetObjResult (rcPtr->interp); + resObj = Tcl_GetObjResult(rcPtr->interp); } else { - /* Non-ok ressult is always treated as an error. - * We have to capture the full state of the result, - * including additional options. + /* + * Non-ok result is always treated as an error. We have to capture + * the full state of the result, including additional options. */ - res = TCL_ERROR; - resObj = RcErrorMarshall (rcPtr->interp); + result = TCL_ERROR; + resObj = MarshallError(rcPtr->interp); } Tcl_IncrRefCount(resObj); } - Tcl_RestoreInterpState (rcPtr->interp, sr); - - /* ... */ + Tcl_RestoreInterpState(rcPtr->interp, sr); + Tcl_Release(rcPtr->interp); - /* Cleanup of the dynamic parts of the command */ + /* + * Cleanup of the dynamic parts of the command. + */ - Tcl_DecrRefCount (methObj); - if (argone) {Tcl_DecrRefCount (argone);} - if (argtwo) {Tcl_DecrRefCount (argtwo);} + 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 RcInvoke has to dispose of it (but only if - * it was returned to it). + /* + * 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 (result) { - *result = res; - } - if (resultObj) { - *resultObj = resObj; + if (resultObjPtr != NULL) { + *resultObjPtr = resObj; } - /* There no need to handle the case where nothing is returned, because for + + /* + * There no need to handle the case where nothing is returned, because for * that case resObj was not set anyway. */ + + return result; } #ifdef TCL_THREADS static void -RcForwardOp (rcPtr, op, dst, param) - ReflectingChannel* rcPtr; /* Channel instance */ - RcOperation op; /* Forwarded driver operation */ - Tcl_ThreadId dst; /* Destination thread */ - CONST VOID* param; /* Arguments */ +ForwardOpToOwnerThread( + ReflectedChannel *rcPtr, /* Channel instance */ + ForwardedOperation op, /* Forwarded driver operation */ + CONST VOID *param) /* Arguments */ { - RcForwardingEvent* evPtr; - RcForwardingResult* resultPtr; - int result; + Tcl_ThreadId dst = rcPtr->thread; + ForwardingEvent *evPtr; + ForwardingResult *resultPtr; + int result; - /* Create and initialize the event and data structures */ + /* + * Create and initialize the event and data structures. + */ - evPtr = (RcForwardingEvent*) ckalloc (sizeof (RcForwardingEvent)); - resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult)); + evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult)); - evPtr->event.proc = RcForwardProc; - evPtr->resultPtr = resultPtr; - evPtr->op = op; - evPtr->rcPtr = rcPtr; - evPtr->param = param; + evPtr->event.proc = ForwardProc; + evPtr->resultPtr = resultPtr; + evPtr->op = op; + evPtr->rcPtr = rcPtr; + evPtr->param = param; - resultPtr->src = Tcl_GetCurrentThread (); - resultPtr->dst = dst; - resultPtr->done = (Tcl_Condition) NULL; + resultPtr->src = Tcl_GetCurrentThread(); + resultPtr->dst = dst; + resultPtr->done = NULL; resultPtr->result = -1; - resultPtr->evPtr = evPtr; + resultPtr->evPtr = evPtr; - /* Now execute the forward */ + /* + * Now execute the forward. + */ Tcl_MutexLock(&rcForwardMutex); TclSpliceIn(resultPtr, forwardList); /* - * Ensure cleanup of the event if any of the two involved threads - * exits while this event is pending or in progress. + * Ensure cleanup of the event if any of the two involved threads exits + * while this event is pending or in progress. */ - Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); - Tcl_CreateThreadExitHandler(RcDstExitProc, (ClientData) evPtr); + Tcl_CreateThreadExitHandler(SrcExitProc, (ClientData) evPtr); + Tcl_CreateThreadExitHandler(DstExitProc, (ClientData) evPtr); /* * Queue the event and poke the other thread's notifier. */ - Tcl_ThreadQueueEvent(dst, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); + 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. + * (*) 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 ? - * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ? - * NOTE (1): See complementary note (2) in "RcSrcExitProc" - * NOTE (1): --- + /* + * 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" */ - Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL); + Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL); } /* @@ -2193,362 +2147,294 @@ RcForwardOp (rcPtr, op, dst, param) TclSpliceOut(resultPtr, forwardList); - resultPtr->nextPtr = NULL; - resultPtr->prevPtr = NULL; + resultPtr->nextPtr = NULL; + resultPtr->prevPtr = NULL; Tcl_MutexUnlock(&rcForwardMutex); Tcl_ConditionFinalize(&resultPtr->done); /* - * Kill the cleanup handlers now, and the result structure as well, - * before returning the success code. + * Kill the cleanup handlers now, and the result structure as well, before + * returning the success code. * * Note: The event structure has already been deleted. */ - Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); - Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr); - - result = resultPtr->result; - ckfree ((char*) resultPtr); + Tcl_DeleteThreadExitHandler(SrcExitProc, (ClientData) evPtr); + Tcl_DeleteThreadExitHandler(DstExitProc, (ClientData) evPtr); + + result = resultPtr->result; + ckfree((char*) resultPtr); } static int -RcForwardProc (evGPtr, mask) - Tcl_Event *evGPtr; - int mask; +ForwardProc( + Tcl_Event *evGPtr, + int mask) { - /* Notes regarding access to the referenced data. + /* + * 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. + * 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. + * 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. */ - RcForwardingEvent* evPtr = (RcForwardingEvent*) evGPtr; - RcForwardingResult* resultPtr = evPtr->resultPtr; - ReflectingChannel* rcPtr = evPtr->rcPtr; - Tcl_Interp* interp = rcPtr->interp; - RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param; - int res = TCL_OK; /* Result code of RcInvokeTclMethod */ - Tcl_Obj* resObj = NULL; /* Interp result of RcInvokeTclMethod */ + ForwardingEvent *evPtr = (ForwardingEvent *) evGPtr; + ForwardingResult *resultPtr = evPtr->resultPtr; + ReflectedChannel *rcPtr = evPtr->rcPtr; + Tcl_Interp *interp = rcPtr->interp; + ForwardParam *paramPtr = evPtr->param; + Tcl_Obj *resObj = NULL; /* Interp result of InvokeTclMethod */ - /* Ignore the event if no one is waiting for its result anymore. + /* + * Ignore the event if no one is waiting for its result anymore. */ if (!resultPtr) { - return 1; + return 1; } paramPtr->code = TCL_OK; - paramPtr->msg = NULL; - paramPtr->vol = 0; + paramPtr->msgStr = NULL; + paramPtr->mustFree = 0; switch (evPtr->op) { - /* The destination thread for the following operations is - * rcPtr->thread, which contains rcPtr->interp, the interp - * we have to call upon for the driver. - */ - - case RcOpClose: - { - /* No parameters/results */ - RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (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 - */ - - RcFree (rcPtr); - } - break; - - case RcOpInput: - { - RcForwardParamInput* p = (RcForwardParamInput*) paramPtr; - Tcl_Obj* toReadObj = Tcl_NewIntObj (p->toRead); - - if (toReadObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcInput"); - } - - RcInvokeTclMethod (rcPtr, "read", toReadObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - p->toRead = -1; - } else { - /* Process a regular result. */ - - int bytec; /* Number of returned bytes */ - unsigned char* bytev; /* Array of returned bytes */ - - bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - - if (p->toRead < bytec) { - RcForwardSetStaticError (paramPtr, msg_read_toomuch); - p->toRead = -1; - - } else { - if (bytec > 0) { - memcpy (p->buf, bytev, bytec); - } - - p->toRead = bytec; - } - } - } - break; - - case RcOpOutput: - { - RcForwardParamOutput* p = (RcForwardParamOutput*) paramPtr; - Tcl_Obj* bufObj = Tcl_NewByteArrayObj((unsigned char*) p->buf, p->toWrite); - - if (bufObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcOutput"); - } - - RcInvokeTclMethod (rcPtr, "write", bufObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - p->toWrite = -1; - } else { - /* Process a regular result. */ - - int written; - - res = Tcl_GetIntFromObj (interp, resObj, &written); - if (res != TCL_OK) { - - RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); - p->toWrite = -1; - - } else if ((written == 0) || (p->toWrite < written)) { - - RcForwardSetStaticError (paramPtr, msg_write_toomuch); - p->toWrite = -1; - - } else { - p->toWrite = written; - } - } - } - break; - - case RcOpSeek: - { - RcForwardParamSeek* p = (RcForwardParamSeek*) paramPtr; - - Tcl_Obj* offObj; - Tcl_Obj* baseObj; - - offObj = Tcl_NewWideIntObj(p->offset); - if (offObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSeekWide"); - } - - baseObj = Tcl_NewStringObj((p->seekMode == SEEK_SET) ? - "start" : - ((p->seekMode == SEEK_CUR) ? - "current" : - "end"), -1); - - if (baseObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSeekWide"); - } - - RcInvokeTclMethod (rcPtr, "seek", offObj, baseObj, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - p->offset = -1; - } else { - /* Process a regular result. If the type is wrong this - * may change into an error. - */ - - Tcl_WideInt newLoc; - res = Tcl_GetWideIntFromObj (interp, resObj, &newLoc); - - if (res == TCL_OK) { - if (newLoc < Tcl_LongAsWide (0)) { - RcForwardSetStaticError (paramPtr, msg_seek_beforestart); - p->offset = -1; - } else { - p->offset = newLoc; - } - } else { - RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); - p->offset = -1; - } - } - } - break; - - case RcOpWatch: - { - RcForwardParamWatch* p = (RcForwardParamWatch*) paramPtr; - - Tcl_Obj* maskObj = RcDecodeEventMask (p->mask); - RcInvokeTclMethod (rcPtr, "watch", maskObj, NULL, - NULL, NULL, NO_CAPTURE); - Tcl_DecrRefCount (maskObj); - } - break; - - case RcOpBlock: - { - RcForwardParamBlock* p = (RcForwardParamBlock*) evPtr->param; - Tcl_Obj* blockObj = Tcl_NewBooleanObj(!p->nonblocking); - - if (blockObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcBlock"); - } - - RcInvokeTclMethod (rcPtr, "blocking", blockObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - } - } - break; - - case RcOpSetOpt: - { - RcForwardParamSetOpt* p = (RcForwardParamSetOpt*) paramPtr; - Tcl_Obj* optionObj; - Tcl_Obj* valueObj; - - optionObj = Tcl_NewStringObj(p->name,-1); - if (optionObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSetOption"); - } - - valueObj = Tcl_NewStringObj(p->value,-1); - if (valueObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcSetOption"); - } - - RcInvokeTclMethod (rcPtr, "configure", optionObj, valueObj, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - } - } - break; - - case RcOpGetOpt: - { - /* Retrieve the value of one option */ - - RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr; - Tcl_Obj* optionObj; - - optionObj = Tcl_NewStringObj(p->name,-1); - if (optionObj == (Tcl_Obj*) NULL) { - Tcl_Panic ("Out of memory in RcGetOption"); - } - - RcInvokeTclMethod (rcPtr, "cget", optionObj, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - } else { - Tcl_DStringAppend (p->value, Tcl_GetString (resObj), -1); - } - } - break; - - case RcOpGetOptAll: - { - /* Retrieve all options. */ - - RcForwardParamGetOpt* p = (RcForwardParamGetOpt*) paramPtr; - - RcInvokeTclMethod (rcPtr, "cgetall", NULL, NULL, - &res, &resObj, DO_CAPTURE); - - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, resObj); - } else { - /* Extract list, validate that it is a list, and - * #elements. See NOTE (4) as well. - */ - - int listc; - Tcl_Obj** listv; - - res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); - if (res != TCL_OK) { - RcForwardSetObjError (paramPtr, RcErrorMarshall (interp)); - - } else if ((listc % 2) == 1) { - /* Odd number of elements is wrong. - * [x]. - */ - - char* buf = ckalloc (200); - sprintf (buf, - "{Expected list with even number of elements, got %d %s instead}", - listc, - (listc == 1 ? "element" : "elements")); - - RcForwardSetDynError (paramPtr, buf); - } else { - int len; - char* str = Tcl_GetStringFromObj (resObj, &len); - - if (len) { - Tcl_DStringAppend (p->value, " ", 1); - Tcl_DStringAppend (p->value, str, len); - } - } - } - } - break; + /* + * The destination thread for the following operations is + * rcPtr->thread, which contains rcPtr->interp, the interp we have to + * call upon for the driver. + */ + + case ForwardedClose: + /* + * No parameters/results. + */ + + if (InvokeTclMethod(rcPtr, "finalize", NULL, NULL, &resObj, + 0) != 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 + */ + + FreeReflectedChannel(rcPtr); + break; + + case ForwardedInput: { + Tcl_Obj *toReadObj = Tcl_NewIntObj(paramPtr->input.toRead); + + if (InvokeTclMethod(rcPtr, "read", toReadObj, NULL, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->input.toRead = -1; + } else { + /* + * Process a regular result. + */ + + int bytec; /* Number of returned bytes */ + unsigned char *bytev; /* Array of returned bytes */ + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + if (paramPtr->input.toRead < bytec) { + ForwardSetStaticError(paramPtr, msg_read_toomuch); + paramPtr->input.toRead = -1; + } else { + if (bytec > 0) { + memcpy(paramPtr->input.buf, bytev, bytec); + } + paramPtr->input.toRead = bytec; + } + } + break; + } + + case ForwardedOutput: { + Tcl_Obj *bufObj = Tcl_NewByteArrayObj((unsigned char *) + paramPtr->output.buf, paramPtr->output.toWrite); + + if (InvokeTclMethod(rcPtr, "write", bufObj, NULL, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->output.toWrite = -1; + } else { + /* + * Process a regular result. + */ + + int written; + + if (Tcl_GetIntFromObj(interp, resObj, &written) != TCL_OK) { + ForwardSetObjError(paramPtr, MarshallError(interp)); + paramPtr->output.toWrite = -1; + } else if (written==0 || paramPtr->output.toWrite<written) { + ForwardSetStaticError(paramPtr, msg_write_toomuch); + paramPtr->output.toWrite = -1; + } else { + paramPtr->output.toWrite = written; + } + } + break; + } + + case ForwardedSeek: { + Tcl_Obj *offObj = Tcl_NewWideIntObj(paramPtr->seek.offset); + Tcl_Obj *baseObj = Tcl_NewStringObj( + (paramPtr->seek.seekMode==SEEK_SET) ? "start" : + (paramPtr->seek.seekMode==SEEK_CUR) ? "current" : "end"), -1); + + if (InvokeTclMethod(rcPtr, "seek", offObj, baseObj, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + paramPtr->seek.offset = -1; + } else { + /* + * Process a regular result. If the type is wrong this may change + * into an error. + */ + + Tcl_WideInt newLoc; + + if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { + if (newLoc < Tcl_LongAsWide(0)) { + ForwardSetStaticError(paramPtr, msg_seek_beforestart); + paramPtr->seek.offset = -1; + } else { + paramPtr->seek.offset = newLoc; + } + } else { + ForwardSetObjError(paramPtr, MarshallError(interp)); + paramPtr->seek.offset = -1; + } + } + break; + } + + case ForwardedWatch: { + Tcl_Obj *maskObj = DecodeEventMask(paramPtr->watch.mask); + + (void) InvokeTclMethod(rcPtr, "watch", maskObj, NULL, NULL, NULL, + INVOKE_NO_CAPTURE); + Tcl_DecrRefCount(maskObj); + break; + } + + case ForwardedBlock: { + Tcl_Obj *blockObj = Tcl_NewBooleanObj(!paramPtr->block.nonblocking); + + if (InvokeTclMethod(rcPtr, "blocking", blockObj, NULL, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } + break; + } + + case ForwardedSetOpt: { + Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->setOpt.name, -1); + Tcl_Obj *valueObj = Tcl_NewStringObj(paramPtr->setOpt.value, -1); + + if (InvokeTclMethod(rcPtr, "configure", optionObj, valueObj, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } + break; + } + + case ForwardedGetOpt: { + /* + * Retrieve the value of one option. + */ + + Tcl_Obj *optionObj = Tcl_NewStringObj(paramPtr->getOpt.name, -1); + + if (InvokeTclMethod(rcPtr, "cget", optionObj, NULL, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } else { + Tcl_DStringAppend(paramPtr->getOpt.value, TclGetString(resObj),-1); + } + break; + } + + case ForwardedGetOptAll: + /* + * Retrieve all options. + */ + + if (InvokeTclMethod(rcPtr, "cgetall", NULL, NULL, &resObj, + 0) != TCL_OK) { + ForwardSetObjError(paramPtr, resObj); + } else { + /* + * Extract list, validate that it is a list, and #elements. See + * NOTE (4) as well. + */ + + int listc; + Tcl_Obj** listv; + + if (Tcl_ListObjGetElements(interp, resObj, &listc, + &listv) != TCL_OK) { + ForwardSetObjError(paramPtr, MarshallError(interp)); + } else if ((listc % 2) == 1) { + /* + * Odd number of elements is wrong. [x]. + */ + + char *buf = ckalloc(200); + sprintf(buf, + "{Expected list with even number of elements, got %d %s instead}", + listc, (listc == 1 ? "element" : "elements")); + + ForwardSetDynamicError(paramPtr, buf); + } else { + int len; + CONST char *str = Tcl_GetStringFromObj(resObj, &len); + + if (len) { + Tcl_DStringAppend(paramPtr->getOpt.value, " ", 1); + Tcl_DStringAppend(paramPtr->getOpt.value, str, len); + } + } + } + break; default: - /* Bad operation code */ - Tcl_Panic ("Bad operation code in RcForwardProc"); - break; + /* + * 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 + /* + * Remove the reference we held on the result of the invoke, if we had + * such. */ + if (resObj != NULL) { - Tcl_DecrRefCount (resObj); + 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. + /* + * Report the forwarding result synchronously to the waiting caller. + * This unblocks (*) as well. This is wrapped into a conditional + * because the caller may have exited in the mean time. */ - Tcl_MutexLock(&rcForwardMutex); + Tcl_MutexLock(&rcForwardMutex); resultPtr->result = TCL_OK; Tcl_ConditionNotify(&resultPtr->done); Tcl_MutexUnlock(&rcForwardMutex); @@ -2557,97 +2443,92 @@ RcForwardProc (evGPtr, mask) return 1; } - static void -RcSrcExitProc (clientData) - ClientData clientData; +SrcExitProc( + ClientData clientData) { - RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; - RcForwardingResult* resultPtr; - RcForwardParamBase* paramPtr; - - /* NOTE (2): Can this handler be called with the originator blocked ? - * NOTE (2): --- - */ + ForwardingEvent *evPtr = (ForwardingEvent *) clientData; + ForwardingResult *resultPtr; + ForwardParam *paramPtr; - /* 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. - */ + /* + * NOTE (2): Can this handler be called with the originator blocked? + */ - /* - * 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 "RcForwardProc", should it already execute the - * event. - */ + /* + * The originator for the event exited. It is not sure if this can happen, + * as the originator should be blocked at (*) while the event is in + * transit/pending. + * + * We make sure that the event cannot refer to the result anymore, remove + * it from the list of pending results and free the structure. Locking the + * access ensures that we cannot get in conflict with "ForwardProc", + * should it already execute the event. + */ - Tcl_MutexLock(&rcForwardMutex); + Tcl_MutexLock(&rcForwardMutex); - resultPtr = evPtr->resultPtr; - paramPtr = (RcForwardParamBase*) evPtr->param; + resultPtr = evPtr->resultPtr; + paramPtr = evPtr->param; - evPtr->resultPtr = NULL; - resultPtr->evPtr = NULL; - resultPtr->result = TCL_ERROR; + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; - RcForwardSetStaticError (paramPtr, msg_send_originlost); + ForwardSetStaticError(paramPtr, msg_send_originlost); - /* See below: TclSpliceOut(resultPtr, forwardList); */ + /* + * See below: TclSpliceOut(resultPtr, forwardList); + */ - Tcl_MutexUnlock(&rcForwardMutex); + Tcl_MutexUnlock(&rcForwardMutex); - /* - * This unlocks (*). The structure will be spliced out and freed by - * "RcForwardProc". Maybe. - */ + /* + * This unlocks (*). The structure will be spliced out and freed by + * "ForwardProc". Maybe. + */ - Tcl_ConditionNotify(&resultPtr->done); + Tcl_ConditionNotify(&resultPtr->done); } - static void -RcDstExitProc (clientData) - ClientData clientData; +DstExitProc( + ClientData clientData) { - RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; - RcForwardingResult* resultPtr = evPtr->resultPtr; - RcForwardParamBase* paramPtr = (RcForwardParamBase*) evPtr->param; + ForwardingEvent *evPtr = (ForwardingEvent *) clientData; + ForwardingResult *resultPtr = evPtr->resultPtr; + ForwardParam *paramPtr = evPtr->param; - /* NOTE (3): It is not clear if the event still exists when this handler is called.. - * NOTE (3): We might have to use 'resultPtr' as our clientData instead. - * NOTE (3): --- - */ + /* + * NOTE (3): It is not clear if the event still exists when this handler + * is called. We might have to use 'resultPtr' as our clientData instead. + */ - /* The receiver for the event exited, before processing the - * event. We detach the result now, wake the originator up - * and signal failure. - */ + /* + * The receiver for the event exited, before processing the event. We + * detach the result now, wake the originator up and signal failure. + */ - evPtr->resultPtr = NULL; - resultPtr->evPtr = NULL; - resultPtr->result = TCL_ERROR; + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; - RcForwardSetStaticError (paramPtr, msg_send_dstlost); + ForwardSetStaticError(paramPtr, msg_send_dstlost); - Tcl_ConditionNotify(&resultPtr->done); + Tcl_ConditionNotify(&resultPtr->done); } - static void -RcForwardSetObjError (p,obj) - RcForwardParamBase* p; - Tcl_Obj* obj; +ForwardSetObjError( + ForwardParam *p, + Tcl_Obj *obj) { - int len; - char* msg; - - msg = Tcl_GetStringFromObj (obj, &len); + int len; + CONST char *msgStr = Tcl_GetStringFromObj(obj, &len); - p->code = TCL_ERROR; - p->vol = 1; - p->msg = strcpy(ckalloc (1+len), msg); + len++; + ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len)); + memcpy(p->base.msgStr, msgStr, (unsigned) len); } #endif |