diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tcl.decls | 17 | ||||
| -rw-r--r-- | generic/tclBasic.c | 23 | ||||
| -rw-r--r-- | generic/tclDecls.h | 46 | ||||
| -rw-r--r-- | generic/tclIO.c | 469 | ||||
| -rw-r--r-- | generic/tclIO.h | 16 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 95 | ||||
| -rw-r--r-- | generic/tclIORChan.c | 2668 | ||||
| -rw-r--r-- | generic/tclInt.h | 53 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 6 | ||||
| -rw-r--r-- | generic/tclTest.c | 116 | ||||
| -rw-r--r-- | generic/tclThreadTest.c | 8 |
11 files changed, 3461 insertions, 56 deletions
diff --git a/generic/tcl.decls b/generic/tcl.decls index 6dd904e..b6417ff 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tcl.decls,v 1.112 2005/06/06 23:45:42 dkf Exp $ +# RCS: @(#) $Id: tcl.decls,v 1.113 2005/08/24 17:56:23 andreas_kupries Exp $ library tcl @@ -2013,6 +2013,21 @@ declare 560 generic { Tcl_ChannelType *chanTypePtr) } +# TIP#219 (Tcl Channel Reflection API) akupries + +declare 561 generic { + void Tcl_SetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj* msg) +} +declare 562 generic { + void Tcl_GetChannelErrorInterp (Tcl_Interp* interp, Tcl_Obj** msg) +} +declare 563 generic { + void Tcl_SetChannelError (Tcl_Channel chan, Tcl_Obj* msg) +} +declare 564 generic { + void Tcl_GetChannelError (Tcl_Channel chan, Tcl_Obj** msg) +} + ############################################################################## # Define the platform specific public Tcl interface. These functions are diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 04582b7..df4abd8 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.166 2005/08/17 23:48:33 georgeps Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.167 2005/08/24 17:56:23 andreas_kupries Exp $ */ #include "tclInt.h" @@ -401,6 +401,9 @@ Tcl_CreateInterp() iPtr->execEnvPtr = TclCreateExecEnv(interp); + /* TIP #219, Tcl Channel Reflection API */ + iPtr->chanMsg = NULL; + /* * Initialize the compilation and execution statistics kept for this * interpreter. @@ -527,9 +530,18 @@ Tcl_CreateInterp() Tcl_CreateObjCommand(interp, "::tcl::clock::Oldscan", TclClockOldscanObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); + /* TIP #208 */ Tcl_CreateObjCommand(interp, "::tcl::chan::Truncate", TclChanTruncateObjCmd, (ClientData) NULL, (Tcl_CmdDeleteProc*) NULL); + /* TIP #219 */ + Tcl_CreateObjCommand(interp, "::tcl::chan::rCreate", + TclChanCreateObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); + + Tcl_CreateObjCommand(interp, "::tcl::chan::rPostevent", + TclChanPostEventObjCmd, (ClientData) NULL, + (Tcl_CmdDeleteProc*) NULL); /* * Register the built-in functions @@ -972,6 +984,15 @@ Tcl_DeleteInterp(interp) iPtr->flags |= DELETED; iPtr->compileEpoch++; + /* TIP #219, Tcl Channel Reflection API. + * Discard a leftover state. + */ + + if (iPtr->chanMsg != NULL) { + Tcl_DecrRefCount (iPtr->chanMsg); + iPtr->chanMsg = NULL; + } + /* * Ensure that the interpreter is eventually deleted. */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index c410983..d10cb4c 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclDecls.h,v 1.114 2005/06/07 02:07:24 dgp Exp $ + * RCS: @(#) $Id: tclDecls.h,v 1.115 2005/08/24 17:56:23 andreas_kupries Exp $ */ #ifndef _TCLDECLS @@ -3496,6 +3496,30 @@ EXTERN int Tcl_TruncateChannel _ANSI_ARGS_((Tcl_Channel chan, EXTERN Tcl_DriverTruncateProc * Tcl_ChannelTruncateProc _ANSI_ARGS_(( Tcl_ChannelType * chanTypePtr)); #endif +#ifndef Tcl_SetChannelErrorInterp_TCL_DECLARED +#define Tcl_SetChannelErrorInterp_TCL_DECLARED +/* 561 */ +EXTERN void Tcl_SetChannelErrorInterp _ANSI_ARGS_(( + Tcl_Interp* interp, Tcl_Obj* msg)); +#endif +#ifndef Tcl_GetChannelErrorInterp_TCL_DECLARED +#define Tcl_GetChannelErrorInterp_TCL_DECLARED +/* 562 */ +EXTERN void Tcl_GetChannelErrorInterp _ANSI_ARGS_(( + Tcl_Interp* interp, Tcl_Obj** msg)); +#endif +#ifndef Tcl_SetChannelError_TCL_DECLARED +#define Tcl_SetChannelError_TCL_DECLARED +/* 563 */ +EXTERN void Tcl_SetChannelError _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj* msg)); +#endif +#ifndef Tcl_GetChannelError_TCL_DECLARED +#define Tcl_GetChannelError_TCL_DECLARED +/* 564 */ +EXTERN void Tcl_GetChannelError _ANSI_ARGS_((Tcl_Channel chan, + Tcl_Obj** msg)); +#endif typedef struct TclStubHooks { struct TclPlatStubs *tclPlatStubs; @@ -4098,6 +4122,10 @@ typedef struct TclStubs { int (*tcl_GetBignumFromObj) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, mp_int* value)); /* 558 */ int (*tcl_TruncateChannel) _ANSI_ARGS_((Tcl_Channel chan, Tcl_WideInt length)); /* 559 */ Tcl_DriverTruncateProc * (*tcl_ChannelTruncateProc) _ANSI_ARGS_((Tcl_ChannelType * chanTypePtr)); /* 560 */ + void (*tcl_SetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* msg)); /* 561 */ + void (*tcl_GetChannelErrorInterp) _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj** msg)); /* 562 */ + void (*tcl_SetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj* msg)); /* 563 */ + void (*tcl_GetChannelError) _ANSI_ARGS_((Tcl_Channel chan, Tcl_Obj** msg)); /* 564 */ } TclStubs; #ifdef __cplusplus @@ -6382,6 +6410,22 @@ extern TclStubs *tclStubsPtr; #define Tcl_ChannelTruncateProc \ (tclStubsPtr->tcl_ChannelTruncateProc) /* 560 */ #endif +#ifndef Tcl_SetChannelErrorInterp +#define Tcl_SetChannelErrorInterp \ + (tclStubsPtr->tcl_SetChannelErrorInterp) /* 561 */ +#endif +#ifndef Tcl_GetChannelErrorInterp +#define Tcl_GetChannelErrorInterp \ + (tclStubsPtr->tcl_GetChannelErrorInterp) /* 562 */ +#endif +#ifndef Tcl_SetChannelError +#define Tcl_SetChannelError \ + (tclStubsPtr->tcl_SetChannelError) /* 563 */ +#endif +#ifndef Tcl_GetChannelError +#define Tcl_GetChannelError \ + (tclStubsPtr->tcl_GetChannelError) /* 564 */ +#endif #endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */ diff --git a/generic/tclIO.c b/generic/tclIO.c index dcb4e9d..8b504a8 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.92 2005/08/04 17:29:01 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.93 2005/08/24 17:56:23 andreas_kupries Exp $ */ #include "tclInt.h" @@ -136,6 +136,7 @@ static int WriteBytes _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); static int WriteChars _ANSI_ARGS_((Channel *chanPtr, CONST char *src, int srcLen)); +static Tcl_Obj* FixLevelCode _ANSI_ARGS_ ((Tcl_Obj* msg)); /* *--------------------------------------------------------------------------- @@ -743,7 +744,7 @@ Tcl_RegisterChannel(interp, chan) hPtr = Tcl_CreateHashEntry(hTblPtr, statePtr->channelName, &new); if (new == 0) { if (chan == (Tcl_Channel) Tcl_GetHashValue(hPtr)) { - return; + return; } Tcl_Panic("Tcl_RegisterChannel: duplicate channel names"); @@ -1182,6 +1183,10 @@ Tcl_CreateChannel(typePtr, chanName, instanceData, mask) chanPtr->inQueueHead = (ChannelBuffer *) NULL; chanPtr->inQueueTail = (ChannelBuffer *) NULL; + /* TIP #219, Tcl Channel Reflection API */ + statePtr->chanMsg = NULL; + statePtr->unreportedMsg = NULL; + /* * Link the channel into the list of all channels; create an on-exit * handler if there is not one already, to close off all the channels in @@ -1400,7 +1405,7 @@ Tcl_StackChannel(interp, typePtr, instanceData, mask, prevChan) * * Side effects: * If TCL_ERROR is returned, the posix error code will be set with - * Tcl_SetErrno. + * Tcl_SetErrno. May leave a message in interp result as well. * *---------------------------------------------------------------------- */ @@ -1446,9 +1451,17 @@ Tcl_UnstackChannel(interp, chan) if (Tcl_Flush((Tcl_Channel) chanPtr) != TCL_OK) { statePtr->csPtr = csPtr; - Tcl_AppendResult(interp, "could not flush channel \"", - Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", - (char *) NULL); + /* TIP #219, Tcl Channel Reflection API. + * Move error messages put by the driver into the chan/ip + * bypass area into the regular interpreter result. Fall back + * to the regular message if nothing was found in the + * bypasses. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "could not flush channel \"", + Tcl_GetChannelName((Tcl_Channel) chanPtr), "\"", + (char *) NULL); + } return TCL_ERROR; } @@ -1517,6 +1530,11 @@ Tcl_UnstackChannel(interp, chan) if (result != 0) { Tcl_SetErrno(result); + /* TIP #219, Tcl Channel Reflection API. + * Move error messages put by the driver into the chan/ip bypass + * area into the regular interpreter result. + */ + TclChanCaughtErrorBypass (interp, chan); return TCL_ERROR; } } else { @@ -1527,6 +1545,10 @@ Tcl_UnstackChannel(interp, chan) if (statePtr->refCount <= 0) { if (Tcl_Close(interp, chan) != TCL_OK) { + /* TIP #219, Tcl Channel Reflection API. + * "TclChanCaughtErrorBypass" is not required here, it was + * done already by "Tcl_Close". + */ return TCL_ERROR; } } @@ -1959,7 +1981,7 @@ CheckForDeadChannel(interp, statePtr) * * Results: * 0 if successful, else the error code that was returned by the channel - * type operation. + * type operation. May leave a message in the interp result. * * Side effects: * May produce output on a channel. May block indefinitely if the channel @@ -2099,22 +2121,53 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) */ if (calledFromAsyncFlush) { + /* TIP #219, Tcl Channel Reflection API. + * When defering the error copy a message from the bypass into + * the unreported area. Or discard it if the new error is to be + * ignored in favor of an earlier defered error. + */ + + Tcl_Obj* msg = statePtr->chanMsg; + if (statePtr->unreportedError == 0) { statePtr->unreportedError = errorCode; + statePtr->unreportedMsg = msg; + if (msg != NULL) { + Tcl_IncrRefCount (msg); + } + } else { + /* An old unreported error is kept, and this error + * thrown away. + */ + statePtr->chanMsg = NULL; + if (msg != NULL) { + Tcl_DecrRefCount (msg); + } } } else { + /* TIP #219, Tcl Channel Reflection API. + * Move error messages put by the driver into the chan bypass + * area into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypasses. + */ + Tcl_SetErrno(errorCode); if (interp != NULL) { + if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) { + /* + * Casting away CONST here is safe because the + * TCL_VOLATILE flag guarantees CONST treatment + * of the Posix error string. + */ - /* - * Casting away CONST here is safe because the - * TCL_VOLATILE flag guarantees CONST treatment of the - * Posix error string. - */ - - Tcl_SetResult(interp, - (char *) Tcl_PosixError(interp), TCL_VOLATILE); + Tcl_SetResult(interp, + (char *) Tcl_PosixError(interp), + TCL_VOLATILE); + } } + /* An unreportable bypassed message is kept, for the + * caller of Tcl_Seek, Tcl_Write, etc. + */ } /* @@ -2191,7 +2244,7 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush) * TOP channel, including the data structure itself. * * Results: - * 1 if the channel was stacked, 0 otherwise. + * Error code from an unreported error or the driver close operation. * * Side effects: * May close the actual channel, may free memory, may change the value of @@ -2251,6 +2304,19 @@ CloseChannel(interp, chanPtr, errorCode) (chanPtr->typePtr->outputProc) (chanPtr->instanceData, &c, 1, &dummy); } + /* TIP #219, Tcl Channel Reflection API. + * Move a leftover error message in the channel bypass into the + * interpreter bypass. Just clear it if there is no interpreter. + */ + + if (statePtr->chanMsg != NULL) { + if (interp != NULL) { + Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg); + } + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } + /* * Remove this channel from of the list of all channels. */ @@ -2259,6 +2325,7 @@ CloseChannel(interp, chanPtr, errorCode) /* * Close and free the channel driver state. + * This may leave a TIP #219 error message in the interp. */ if (chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) { @@ -2293,6 +2360,17 @@ CloseChannel(interp, chanPtr, errorCode) if (statePtr->unreportedError != 0) { errorCode = statePtr->unreportedError; + + /* TIP #219, Tcl Channel Reflection API. + * Move an error message found in the unreported area into the regular + * bypass (interp). This kills any message in the channel bypass area. + */ + + if (statePtr->chanMsg != NULL) { + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } + Tcl_SetChannelErrorInterp (interp,statePtr->unreportedMsg); } if (errorCode == 0) { errorCode = result; @@ -2500,6 +2578,7 @@ Tcl_Close(interp, chan) Channel *chanPtr; /* The real IO channel. */ ChannelState *statePtr; /* State of real IO channel. */ int result; /* Of calling FlushChannel. */ + int flushcode; if (chan == (Tcl_Channel) NULL) { return TCL_OK; @@ -2543,6 +2622,19 @@ Tcl_Close(interp, chan) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; WriteChars(chanPtr, "", 0); + + /* TIP #219, Tcl Channel Reflection API. + * Move an error message found in the channel bypass into the + * interpreter bypass. Just clear it if there is no interpreter. + */ + + if (statePtr->chanMsg != NULL) { + if (interp != NULL) { + Tcl_SetChannelErrorInterp (interp,statePtr->chanMsg); + } + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } } Tcl_ClearChannelHandlers(chan); @@ -2588,7 +2680,25 @@ Tcl_Close(interp, chan) */ statePtr->flags |= CHANNEL_CLOSED; - if ((FlushChannel(interp, chanPtr, 0) != 0) || (result != 0)) { + + flushcode = FlushChannel(interp, chanPtr, 0); + + /* TIP #219. + * Capture error messages put by the driver into the bypass area and put + * them into the regular interpreter result. + * + * Notes: Due to the assertion of CHANNEL_CLOSED in the flags + * "FlushChannel" has called "CloseChannel" and thus freed all the channel + * structures. We must not try to access "chan" anymore, hence the NULL + * argument in the call below. The only place which may still contain a + * message is the interpreter itself, and "CloseChannel" made sure to lift + * any channel message it generated into it. + */ + if (TclChanCaughtErrorBypass (interp, NULL)) { + result = EINVAL; + } + + if ((flushcode != 0) || (result != 0)) { return TCL_ERROR; } return TCL_OK; @@ -5831,6 +5941,16 @@ CheckChannelErrors(statePtr, flags) if (statePtr->unreportedError != 0) { Tcl_SetErrno(statePtr->unreportedError); statePtr->unreportedError = 0; + + /* TIP #219, Tcl Channel Reflection API. + * Move a defered error message back into the channel bypass. + */ + + if (statePtr->chanMsg != NULL) { + Tcl_DecrRefCount (statePtr->chanMsg); + } + statePtr->chanMsg = statePtr->unreportedMsg; + statePtr->unreportedMsg = NULL; return -1; } @@ -7725,6 +7845,7 @@ CopyData(csPtr, mask) { Tcl_Interp *interp; Tcl_Obj *cmdPtr, *errObj = NULL, *bufObj = NULL; + Tcl_Obj* msg = NULL; Tcl_Channel inChan, outChan; ChannelState *inStatePtr, *outStatePtr; int result = TCL_OK, size, total, sizeb; @@ -7762,12 +7883,14 @@ CopyData(csPtr, mask) * Check for unreported background errors. */ - if (inStatePtr->unreportedError != 0) { + Tcl_GetChannelError (inChan, &msg); + if ((inStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(inStatePtr->unreportedError); inStatePtr->unreportedError = 0; goto readError; } - if (outStatePtr->unreportedError != 0) { + Tcl_GetChannelError (outChan, &msg); + if ((outStatePtr->unreportedError != 0) || (msg != NULL)) { Tcl_SetErrno(outStatePtr->unreportedError); outStatePtr->unreportedError = 0; goto writeError; @@ -7794,8 +7917,15 @@ CopyData(csPtr, mask) readError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error reading \"", - Tcl_GetChannelName(inChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_GetChannelName(inChan), "\": ", + (char *) NULL); + if (msg != NULL) { + Tcl_AppendObjToObj(errObj,msg); + } else { + Tcl_AppendStringsToObj(errObj, + Tcl_PosixError(interp), + (char *) NULL); + } break; } else if (underflow) { /* @@ -7850,8 +7980,15 @@ CopyData(csPtr, mask) writeError: TclNewObj(errObj); Tcl_AppendStringsToObj(errObj, "error writing \"", - Tcl_GetChannelName(outChan), "\": ", - Tcl_PosixError(interp), (char *) NULL); + Tcl_GetChannelName(outChan), "\": ", + (char *) NULL); + if (msg != NULL) { + Tcl_AppendObjToObj(errObj,msg); + } else { + Tcl_AppendStringsToObj(errObj, + Tcl_PosixError(interp), + (char *) NULL); + } break; } @@ -8693,8 +8830,26 @@ SetBlockMode(interp, chanPtr, mode) result = StackSetBlockMode(chanPtr, mode); if (result != 0) { if (interp != (Tcl_Interp *) NULL) { - Tcl_AppendResult(interp, "error setting blocking mode: ", - Tcl_PosixError(interp), (char *) NULL); + /* TIP #219. + * Move error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + * + * Note that we cannot have a message in the interpreter bypass + * area, StackSetBlockMode is restricted to the channel bypass. + * We still need the interp as the destination of the move. + */ + if (!TclChanCaughtErrorBypass (interp, (Tcl_Channel) chanPtr)) { + Tcl_AppendResult(interp, "error setting blocking mode: ", + Tcl_PosixError(interp), (char *) NULL); + } + } else { + /* TIP #219. + * If we have no interpreter to put a bypass message into we have + * to clear it, to prevent its propagation and use in other places + * unrelated to the actual occurence of the problem. + */ + Tcl_SetChannelError ((Tcl_Channel) chanPtr, NULL); } return TCL_ERROR; } @@ -9376,6 +9531,270 @@ Tcl_ChannelThreadActionProc(chanTypePtr) /* *---------------------------------------------------------------------- * + * Tcl_SetChannelErrorInterp -- + * + * TIP #219, Tcl Channel Reflection API. + * Store an error message for the I/O system. + * + * Results: + * None. + * + * Side effects: + * Discards a previously stored message. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelErrorInterp (interp, msg) + Tcl_Interp* interp; /* Interp to store the data into. */ + Tcl_Obj* msg; /* Error message to store. */ +{ + Interp* iPtr = (Interp*) interp; + + if (iPtr->chanMsg != NULL) { + Tcl_DecrRefCount (iPtr->chanMsg); + iPtr->chanMsg = NULL; + } + + if (msg != NULL) { + iPtr->chanMsg = FixLevelCode (msg); + Tcl_IncrRefCount (iPtr->chanMsg); + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetChannelError -- + * + * TIP #219, Tcl Channel Reflection API. + * Store an error message for the I/O system. + * + * Results: + * None. + * + * Side effects: + * Discards a previously stored message. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetChannelError (chan, msg) + Tcl_Channel chan; /* Channel to store the data into. */ + Tcl_Obj* msg; /* Error message to store. */ +{ + ChannelState* statePtr = ((Channel*) chan)->state; + + if (statePtr->chanMsg != NULL) { + Tcl_DecrRefCount (statePtr->chanMsg); + statePtr->chanMsg = NULL; + } + + if (msg != NULL) { + statePtr->chanMsg = FixLevelCode (msg); + Tcl_IncrRefCount (statePtr->chanMsg); + } + return; +} + +/* + *---------------------------------------------------------------------- + * + * FixLevelCode -- + * + * TIP #219, Tcl Channel Reflection API. + * Scans an error message for bad -code / -level + * directives. Returns a modified copy with such + * directives corrected, and the input if it had + * no problems. + * + * Results: + * A Tcl_Obj* + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +FixLevelCode (msg) +Tcl_Obj* msg; +{ + int lc; + Tcl_Obj** lv; + int explicitResult; + int numOptions; + int lcn; + Tcl_Obj** lvn; + int res, i, j, val, lignore, cignore; + Tcl_Obj* newlevel = NULL; + Tcl_Obj* newcode = NULL; + + /* ASSERT msg != NULL */ + + /* Process the caught message. + * + * Syntax = (option value)... ?message? + * + * Bad syntax causes a panic. Because the other side uses + * Tcl_GetReturnOptions and list construction functions to marshall the + * information. + */ + + res = Tcl_ListObjGetElements (NULL, msg, &lc, &lv); + if (res != TCL_OK) { + Tcl_Panic ("Tcl_SetChannelError(Interp): Bad syntax of message"); + } + + explicitResult = (1 == (lc % 2)); + numOptions = lc - explicitResult; + + /* No options, nothing to do. + */ + + if (numOptions == 0) { + return msg; + } + + /* Check for -code x, x != 1|error, and -level x, x != 0 */ + + for (i = 0; i < numOptions; i += 2) { + if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) { + /* !"error", !integer, integer != 1 (numeric code for error) */ + + res = Tcl_GetIntFromObj (NULL, lv [i+1], &val); + if (((res == TCL_OK) && (val != 1)) || + ((res != TCL_OK) && (0 != strcmp (Tcl_GetString (lv [i+1]), "error")))) { + newcode = Tcl_NewIntObj (1); + } + } else if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) { + /* !integer, integer != 0 */ + res = Tcl_GetIntFromObj (NULL, lv [i+1], &val); + if ((res != TCL_OK) || (val != 0)) { + newlevel = Tcl_NewIntObj (0); + } + } + } + + /* -code, -level are either not present or ok. Nothing to do. + */ + + if (!newlevel && !newcode) { + return msg; + } + + lcn = numOptions; + if (explicitResult) lcn ++; + if (newlevel) lcn += 2; + if (newcode) lcn += 2; + + lvn = (Tcl_Obj**) ckalloc (lcn * sizeof (Tcl_Obj*)); + + /* New level/code information is spliced into the first occurence of + * -level, -code, further occurences are ignored. The options cannot be + * not present, we would not come here. Options which are ok are simply + * copied over. + */ + + lignore = cignore = 0; + for (i = 0, j = 0; i < numOptions; i += 2) { + if (0 == strcmp (Tcl_GetString (lv [i]), "-level")) { + if (newlevel) { + lvn [j] = lv [i]; j++; + lvn [j] = newlevel; j++; + newlevel = NULL; + lignore = 1; + continue; + } else if (lignore) { + continue; + } + } else if (0 == strcmp (Tcl_GetString (lv [i]), "-code")) { + if (newcode) { + lvn [j] = lv [i]; j++; + lvn [j] = newcode; j++; + newcode = NULL; + cignore = 1; + continue; + } else if (cignore) { + continue; + } + } + /* Keep everything else, possibly copied down */ + lvn [j] = lv [i]; j++; + lvn [j] = lv [i+1]; j++; + } + + if (explicitResult) { + lvn [j] = lv [i]; j++; + } + + msg = Tcl_NewListObj (j, lvn); + + ckfree ((char*) lvn); + return msg; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelErrorInterp -- + * + * TIP #219, Tcl Channel Reflection API. + * Return the message stored by the channel driver. + * + * Results: + * Tcl error message object. + * + * Side effects: + * Resets the stored data to NULL. + * + *---------------------------------------------------------------------- + */ + +void Tcl_GetChannelErrorInterp (interp, msg) + Tcl_Interp* interp; /* Interp to query. */ + Tcl_Obj** msg; /* Place for error message. */ +{ + Interp* iPtr = (Interp*) interp; + + *msg = iPtr->chanMsg; + iPtr->chanMsg = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetChannelError -- + * + * TIP #219, Tcl Channel Reflection API. + * Return the message stored by the channel driver. + * + * Results: + * Tcl error message object. + * + * Side effects: + * Resets the stored data to NULL. + * + *---------------------------------------------------------------------- + */ + +void Tcl_GetChannelError (chan, msg) + Tcl_Channel chan; /* Channel to query. */ + Tcl_Obj** msg; /* Place for error message. */ +{ + ChannelState* statePtr = ((Channel*) chan)->state; + + *msg = statePtr->chanMsg; + statePtr->chanMsg = NULL; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_ChannelTruncateProc -- * * TIP #208 (subsection relating to truncation, based on TIP #206). diff --git a/generic/tclIO.h b/generic/tclIO.h index c0abec2..9ec4abc 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.h,v 1.7 2004/07/15 20:46:49 andreas_kupries Exp $ + * RCS: @(#) $Id: tclIO.h,v 1.8 2005/08/24 17:56:23 andreas_kupries Exp $ */ /* @@ -235,6 +235,20 @@ typedef struct ChannelState { /* Next in list of channels currently open. */ Tcl_ThreadId managingThread; /* TIP #10: Id of the thread managing * this stack of channels. */ + + /* TIP #219 ... Info for the I/O system ... + * Error message set by channel drivers, for the propagation of + * arbitrary Tcl errors. This information, if present (chanMsg not + * NULL), takes precedence over a posix error code returned by a + * channel operation. + */ + + Tcl_Obj* chanMsg; + Tcl_Obj* unreportedMsg; /* Non-NULL if an error report was + * deferred because it happened in the + * background. The value is the + * chanMg, if any. #219's companion to + * 'unreportedError'. */ } ChannelState; /* diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index fa1fac1..9a7d308 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOCmd.c,v 1.30 2005/07/17 22:06:42 dkf Exp $ + * RCS: @(#) $Id: tclIOCmd.c,v 1.31 2005/08/24 17:56:23 andreas_kupries Exp $ */ #include "tclInt.h" @@ -141,8 +141,15 @@ Tcl_PutsObjCmd(dummy, interp, objc, objv) return TCL_OK; error: - Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", - Tcl_PosixError(interp), (char *) NULL); + /* TIP #219. + * Capture error messages put by the driver into the bypass area and put + * them into the regular interpreter result. Fall back to the regular + * message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "error writing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } return TCL_ERROR; } @@ -191,8 +198,15 @@ Tcl_FlushObjCmd(dummy, interp, objc, objv) } if (Tcl_Flush(chan) != TCL_OK) { - Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", - Tcl_PosixError(interp), (char *) NULL); + /* TIP #219. + * Capture error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "error flushing \"", channelId, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } return TCL_ERROR; } return TCL_OK; @@ -250,9 +264,17 @@ Tcl_GetsObjCmd(dummy, interp, objc, objv) if (lineLen < 0) { if (!Tcl_Eof(chan) && !Tcl_InputBlocked(chan)) { Tcl_DecrRefCount(linePtr); - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), (char *) NULL); + + /* TIP #219. + * Capture error messages put by the driver into the bypass area + * and put them into the regular interpreter result. Fall back to + * the regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + } return TCL_ERROR; } lineLen = -1; @@ -372,10 +394,17 @@ Tcl_ReadObjCmd(dummy, interp, objc, objv) Tcl_IncrRefCount(resultPtr); charactersRead = Tcl_ReadChars(chan, resultPtr, toRead, 0); if (charactersRead < 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading \"", name, "\": ", - Tcl_PosixError(interp), (char *) NULL); - Tcl_DecrRefCount(resultPtr); + /* TIP #219. + * Capture error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading \"", name, "\": ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + } return TCL_ERROR; } @@ -457,8 +486,16 @@ Tcl_SeekObjCmd(clientData, interp, objc, objv) result = Tcl_Seek(chan, offset, mode); if (result == Tcl_LongAsWide(-1)) { - Tcl_AppendResult(interp, "error during seek on \"", - chanName, "\": ", Tcl_PosixError(interp), (char *) NULL); + /* TIP #219. + * Capture error messages put by the driver into the bypass area and + * put them into the regular interpreter result. Fall back to the + * regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_AppendResult(interp, "error during seek on \"", + chanName, "\": ", Tcl_PosixError(interp), + (char *) NULL); + } return TCL_ERROR; } return TCL_OK; @@ -491,6 +528,7 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) { Tcl_Channel chan; /* The channel to tell on. */ char *chanName; + Tcl_WideInt newLoc; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "channelId"); @@ -507,7 +545,18 @@ Tcl_TellObjCmd(clientData, interp, objc, objv) if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_Tell(chan))); + + newLoc = Tcl_Tell(chan); + + /* TIP #219. + * Capture error messages put by the driver into the bypass area and put + * them into the regular interpreter result. + */ + if (TclChanCaughtErrorBypass (interp, chan)) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(newLoc)); return TCL_OK; } @@ -833,10 +882,17 @@ Tcl_ExecObjCmd(dummy, interp, objc, objv) resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "error reading output from command: ", - Tcl_PosixError(interp), (char *) NULL); - Tcl_DecrRefCount(resultPtr); + /* TIP #219. + * Capture error messages put by the driver into the bypass area + * and put them into the regular interpreter result. Fall back to + * the regular message if nothing was found in the bypass. + */ + if (!TclChanCaughtErrorBypass (interp, chan)) { + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "error reading output from command: ", + Tcl_PosixError(interp), (char *) NULL); + Tcl_DecrRefCount(resultPtr); + } return TCL_ERROR; } } @@ -1630,3 +1686,4 @@ TclChanTruncateObjCmd(dummy, interp, objc, objv) * fill-column: 78 * End: */ + diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c new file mode 100644 index 0000000..beebff4 --- /dev/null +++ b/generic/tclIORChan.c @@ -0,0 +1,2668 @@ +/* + * tclIORChan.c -- + * + * This file contains the implementation of Tcl's generic + * channel reflection code, which allows the implementation + * of Tcl channels in Tcl code. + * + * Parts of this file are based on code contributed by + * Jean-Claude Wippler. + * + * See TIP #219 for the specification of this functionality. + * + * Copyright (c) 2004-2005 ActiveState, a divison of Sophos + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclIORChan.c,v 1.1 2005/08/24 17:56:23 andreas_kupries Exp $ + */ + +#include <tclInt.h> +#include <tclIO.h> +#include <assert.h> + +#ifndef EINVAL +#define EINVAL 9 +#endif +#ifndef EOK +#define EOK 0 +#endif + +/* + * Signatures of all functions used in the C layer of the reflection. + */ + +/* 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)); + + +/* + * 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 */ +}; + +/* + * Instance data for a reflected channel. =========================== + */ + +typedef struct { + Tcl_Channel chan; /* Back reference to generic channel structure. + */ + Tcl_Interp* interp; /* Reference to the interpreter containing the + * Tcl level part of the channel. */ +#ifdef TCL_THREADS + Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ +#endif + + /* See [==] as well. + * Storage for the command prefix and the additional words required + * for the invocation of methods in the command handler. + * + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + * ~~~~ CT ~~~ ~~ CT ~~ + * + * CT = Belongs to the 'Command handler Thread'. + */ + + int argc; /* Number of preallocated words - 2 */ + Tcl_Obj** argv; /* Preallocated array for calling the handler. + * args [0] is placeholder for cmd word. + * Followed by the arguments in the prefix, + * plus 4 placeholders for method, channel, + * and at most two varying (method specific) + * words. + */ + + int methods; /* Bitmask of supported methods */ + + /* ---------------------------------------- */ + + /* NOTE (9): Should we have predefined shared literals + * 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; + +/* + * Event literals. ================================================== + */ + +static CONST char *eventOptions[] = { + "read", "write", (char *) NULL +}; +typedef enum { + EVENT_READ, EVENT_WRITE +} EventOption; + +/* + * Method literals. ================================================== + */ + +static CONST char *methodNames[] = { + "blocking", /* OPT */ + "cget", /* OPT \/ Together or none */ + "cgetall", /* OPT /\ of these two */ + "configure", /* OPT */ + "finalize", /* */ + "initialize", /* */ + "read", /* OPT */ + "seek", /* OPT */ + "watch", /* */ + "write", /* OPT */ + (char *) NULL +}; +typedef enum { + METH_BLOCKING, + METH_CGET, + METH_CGETALL, + METH_CONFIGURE, + METH_FINAL, + METH_INIT, + METH_READ, + METH_SEEK, + METH_WATCH, + METH_WRITE, +} MethodName; + +#define FLAG(m) (1 << (m)) +#define REQUIRED_METHODS (FLAG (METH_INIT) | FLAG (METH_FINAL) | FLAG (METH_WATCH)) +#define NULLABLE_METHODS (FLAG (METH_BLOCKING) | FLAG (METH_SEEK) | \ + FLAG (METH_CONFIGURE) | FLAG (METH_CGET) | FLAG (METH_CGETALL)) + +#define RANDW (TCL_READABLE|TCL_WRITABLE) + +#define IMPLIES(a,b) ((!(a)) || (b)) +#define NEGIMPL(a,b) +#define HAS(x,f) (x & FLAG(f)) + + +#ifdef TCL_THREADS +/* + * Thread specific types and structures. + * + * We are here essentially creating a very specific implementation of + * 'thread send'. + */ + +/* + * Enumeration of all operations which can be forwarded. + */ + +typedef enum { + RcOpClose, + RcOpInput, + RcOpOutput, + RcOpSeek, + RcOpWatch, + RcOpBlock, + RcOpSetOpt, + RcOpGetOpt, + RcOpGetOptAll +} RcOperation; + +/* + * 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; + +/* + * Operation specific parameter/result structures. + */ + +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; + +/* + * General event structure, with reference to + * operation specific data. + */ + +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; + +/* + * 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. + */ + +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; + +/* + * List of forwarded operations which have not completed yet, plus the + * mutex to protect the access to this process global list. + */ + +static RcForwardingResult* forwardList = (RcForwardingResult*) NULL; +TCL_DECLARE_MUTEX (rcForwardMutex) + +/* + * Function containing the generic code executing a forward, and + * wrapper macros for the actual operations we wish to forward. + */ + +static void +RcForwardOp _ANSI_ARGS_ ((ReflectingChannel* rcPtr, RcOperation op, + Tcl_ThreadId dst, CONST VOID* param)); + +/* + * The event function executed by the thread receiving a forwarding + * event. Executes the appropriate function and collects the result, + * if any. + */ + +static int +RcForwardProc _ANSI_ARGS_ ((Tcl_Event *evPtr, int mask)); + +/* + * 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). + */ + +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)); + +#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)); + + + +/* + * 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 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) + +/* + * Global constant strings (messages). ================== + * These string are used directly as bypass errors, thus they have to be valid + * Tcl lists where the last element is the message itself. Hence the + * list-quoting to keep the words of the message together. See also [x]. + */ + +static CONST char* msg_read_unsup = "{read not supported by Tcl driver}"; +static CONST char* msg_read_toomuch = "{read delivered more than requested}"; +static CONST char* msg_write_unsup = "{write not supported by Tcl driver}"; +static CONST char* msg_write_toomuch = "{write wrote more than requested}"; +static CONST char* msg_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}"; +#endif /* TCL_THREADS */ + +/* + * Main methods to plug into the 'chan' ensemble'. ================== + */ + +/* + *---------------------------------------------------------------------- + * + * TclChanCreateObjCmd -- + * + * This procedure is invoked to process the "chan create" Tcl + * command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * The handle of the new channel is placed in the interp result. + * + * Side effects: + * Creates a new channel. + * + *---------------------------------------------------------------------- + */ + +int +TclChanCreateObjCmd (/*ignored*/ clientData, interp, objc, objv) + 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 + * [0] [1] [2] [3] + * + * Actually: rCreate MODE CMDPREFIX + * [0] [1] [2] + */ + +#define MODE (1) +#define CMD (2) + + /* Number of arguments ... */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "mode cmdprefix"); + return TCL_ERROR; + } + + /* First argument is a list of modes. Allowed entries are "read", + * "write". Expect at least one list element. Abbreviations are + * ok. + */ + + modeObj = objv [MODE]; + if (RcEncodeEventMask (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. + */ + + cmdObj = objv [CMD]; + + /* Basic check that the command prefix truly is a list. */ + + if (Tcl_ListObjIndex(interp, cmdObj, 0, &cmdNameObj) != TCL_OK) { + return TCL_ERROR; + } + + /* Now create the channel. + */ + + rcId = RcNewHandle (); + rcPtr = RcNew (interp, cmdObj, mode, rcId); + chan = Tcl_CreateChannel (&tclRChannelType, + Tcl_GetString (rcId), + rcPtr, mode); + rcPtr->chan = chan; + chanPtr = (Channel*) chan; + + /* Invoke 'initialize' and validate that the handler + * is present and ok. Squash the channel if not. + */ + + /* Note: The conversion of 'mode' back into a Tcl_Obj ensures that + * 'initialize' is invoked with canonical mode names, and no + * abbreviations. Using modeObj directly could feed abbreviations + * into the handler, and the handler is not specified to handle + * such. + */ + + modeObj = RcDecodeEventMask (mode); + RcInvokeTclMethod (rcPtr, "initialize", modeObj, NULL, + &res, &resObj, NO_CAPTURE); + Tcl_DecrRefCount (modeObj); + + 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 */ + goto error; + } + + /* Verify the result. + * - List, of method names. Convert to mask. + * Check for non-optionals through the mask. + * Compare open mode against optional r/w. + */ + + Tcl_AppendResult (interp, "Initialize failure: ", (char*) 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 + */ + + Tcl_Obj* err = Tcl_NewStringObj ("Initialize failure: ",-1); + + 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); + + Tcl_AppendObjToObj(err,Tcl_GetObjResult (interp)); + Tcl_SetObjResult (interp,err); + goto error; + } + + methods |= FLAG (methIndex); + listc --; + } + + if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { + Tcl_AppendResult (interp, "Not all required methods supported", + (char*) NULL); + goto error; + } + + if ((mode & TCL_READABLE) && !HAS(methods,METH_READ)) { + Tcl_AppendResult (interp, "Reading not supported, but requested", + (char*) NULL); + goto error; + } + + if ((mode & TCL_WRITABLE) && !HAS(methods,METH_WRITE)) { + Tcl_AppendResult (interp, "Writing not supported, but requested", + (char*) 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); + 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); + goto error; + } + + Tcl_ResetResult (interp); + + /* Everything is fine now */ + + rcPtr->methods = methods; + + if ((methods & NULLABLE_METHODS) != NULLABLE_METHODS) { + /* Some of the nullable methods are not supported. We clone + * the channel type, null the associated C functions, and use + * the result as the actual channel type. + */ + + Tcl_ChannelType* clonePtr = (Tcl_ChannelType*) ckalloc (sizeof (Tcl_ChannelType)); + if (clonePtr == (Tcl_ChannelType*) NULL) { + Tcl_Panic ("Out of memory in Tcl_RcCreate"); + } + + memcpy (clonePtr, &tclRChannelType, sizeof (Tcl_ChannelType)); + + if (!(methods & FLAG (METH_CONFIGURE))) { + clonePtr->setOptionProc = NULL; + } + + if ( + !(methods & FLAG (METH_CGET)) && + !(methods & FLAG (METH_CGETALL)) + ) { + clonePtr->getOptionProc = NULL; + } + if (!(methods & FLAG (METH_BLOCKING))) { + clonePtr->blockModeProc = NULL; + } + if (!(methods & FLAG (METH_SEEK))) { + clonePtr->seekProc = NULL; + clonePtr->wideSeekProc = NULL; + } + + chanPtr->typePtr = clonePtr; + } + + Tcl_RegisterChannel (interp, chan); + + /* Return handle as result of command */ + + Tcl_SetObjResult (interp, rcId); + return TCL_OK; + + error: + /* Signal to RcClose to not call 'finalize' */ + rcPtr->methods = 0; + Tcl_Close (interp, chan); + return TCL_ERROR; + +#undef MODE +#undef CMD +} + +/* + *---------------------------------------------------------------------- + * + * TclChanPostEventObjCmd -- + * + * This procedure is invoked to process the "chan postevent" + * Tcl command. See the user documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Posts events to a reflected channel, invokes event handlers. + * The latter implies that arbitrary side effects are possible. + * + *---------------------------------------------------------------------- + */ + +int +TclChanPostEventObjCmd (/*ignored*/ clientData, interp, objc, objv) + ClientData clientData; + Tcl_Interp* interp; + int objc; + Tcl_Obj* CONST* objv; +{ + /* Syntax: chan postevent CHANNEL EVENTSPEC + * [0] [1] [2] [3] + * + * Actually: rPostevent CHANNEL EVENTSPEC + * [0] [1] [2] + * + * where EVENTSPEC = {read write ...} (Abbreviations allowed as well. + */ + +#define CHAN (1) +#define EVENT (2) + + CONST char* chanId; /* Tcl level channel handle */ + Tcl_Channel chan; /* Channel associated to the handle */ + 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 */ + + /* Number of arguments ... */ + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "channel eventspec"); + return TCL_ERROR; + } + + /* First argument is a channel, a reflected channel, and the call + * of this command is done from the interp defining the channel + * handler cmd. + */ + + chanId = Tcl_GetString (objv [CHAN]); + chan = Tcl_GetChannel(interp, chanId, &mode); + + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + chanTypePtr = Tcl_GetChannelType (chan); + + /* We use a function referenced by the channel type as our cookie + * to detect calls to non-reflecting channels. The channel type + * itself is not suitable, as it might not be the static + * definition in this file, but a clone thereof. And while we have + * reserved the name of the type nothing in the core checks + * against violation, so someone else might have created a channel + * type using our name, clashing with ourselves. + */ + + if (chanTypePtr->watchProc != &RcWatch) { + Tcl_AppendResult(interp, "channel \"", chanId, + "\" is not a reflected channel", + (char *) NULL); + return TCL_ERROR; + } + + rcPtr = (ReflectingChannel*) Tcl_GetChannelInstanceData (chan); + + if (rcPtr->interp != interp) { + Tcl_AppendResult(interp, "postevent for channel \"", chanId, + "\" called from outside interpreter", + (char *) 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. + */ + + if (RcEncodeEventMask (interp, "event", objv [EVENT], &events) != TCL_OK) { + return TCL_ERROR; + } + + /* Check that the channel is actually interested in the provided + * events. + */ + + if (events & ~rcPtr->interest) { + Tcl_AppendResult(interp, "tried to post events channel \"", chanId, + "\" is not interested in", + (char *) NULL); + return TCL_ERROR; + } + + /* We have the channel and the events to post. + */ + + Tcl_NotifyChannel (chan, events); + + /* Squash interp results left by the event script. + */ + + Tcl_ResetResult (interp); + return TCL_OK; + +#undef CHAN +#undef EVENT +} + + +static Tcl_Obj* +RcErrorMarshall (interp) + Tcl_Interp *interp; +{ + /* Capture the result status of the interpreter into a string. + * => List of options and values, followed by the error message. + * The result has refCount 0. + */ + + Tcl_Obj* returnOpt = Tcl_GetReturnOptions (interp, TCL_ERROR); + + /* => returnOpt.refCount == 0. We can append directly. + */ + + Tcl_ListObjAppendElement (NULL, returnOpt, Tcl_GetObjResult (interp)); + return returnOpt; +} + +static void +RcErrorReturn (interp, msg) + Tcl_Interp *interp; + Tcl_Obj *msg; +{ + int res; + int lc; + Tcl_Obj** lv; + int explicitResult; + int numOptions; + + /* Process the caught message. + * + * Syntax = (option value)... ?message? + * + * Bad syntax causes a panic. Because the other side uses + * Tcl_GetReturnOptions and list construction functions to marshall the + * information. + */ + + res = Tcl_ListObjGetElements (interp, msg, &lc, &lv); + if (res != TCL_OK) { + Tcl_Panic ("TclChanCaughtErrorBypass: Bad syntax of caught result"); + } + + explicitResult = (1 == (lc % 2)); + numOptions = lc - explicitResult; + + if (explicitResult) { + Tcl_SetObjResult (interp, lv [lc-1]); + } + + (void) Tcl_SetReturnOptions(interp, Tcl_NewListObj (numOptions, lv)); +} + +int +TclChanCaughtErrorBypass (interp, chan) + Tcl_Interp *interp; + Tcl_Channel chan; +{ + Tcl_Obj* msgc = NULL; + Tcl_Obj* msgi = NULL; + Tcl_Obj* msg = NULL; + + /* Get a bypassed error message from channel and/or interpreter, save the + * reference, then kill the returned objects, if there were any. If there + * are messages in both the channel has preference. + */ + + if ((chan == NULL) && (interp == NULL)) { + return 0; + } + + if (chan != NULL) { + Tcl_GetChannelError (chan, &msgc); + } + if (interp != NULL) { + Tcl_GetChannelErrorInterp (interp, &msgi); + } + + if (msgc != NULL) { + msg = msgc; + Tcl_IncrRefCount (msg); + } else if (msgi != NULL) { + msg = msgi; + Tcl_IncrRefCount (msg); + } + + if (msgc != NULL) { + Tcl_DecrRefCount (msgc); + } + if (msgi != NULL) { + Tcl_DecrRefCount (msgi); + } + + /* No message returned, nothing caught. + */ + + if (msg == NULL) { + return 0; + } + + RcErrorReturn (interp, msg); + + Tcl_DecrRefCount (msg); + return 1; +} + +/* + * Driver functions. ================================================ + */ + +/* + *---------------------------------------------------------------------- + * + * RcClose -- + * + * This function is invoked when the channel is closed, to delete + * the driver specific instance data. + * + * Results: + * A posix error. + * + * Side effects: + * Releases memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcClose (clientData, interp) + 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. + */ + + /* 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 ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamClose p; + + 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! + */ + + if (res != TCL_OK) { + RcFreeReceivedError (p.b); + } + } else { +#endif + RcFree (rcPtr); +#ifdef TCL_THREADS + } +#endif + return EOK; + } + + /* -------- */ + + /* -- No -- ASSERT rcPtr->methods & FLAG (METH_FINAL) */ + + /* A cleaned method mask here implies that the channel creation + * was aborted, and "finalize" must not be called. + */ + + if (rcPtr->methods == 0) { + RcFree (rcPtr); + return EOK; + } else { +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamClose p; + + 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! + */ + + if (res != TCL_OK) { + RcPassReceivedErrorInterp (interp, p.b); + } + } else { +#endif + RcInvokeTclMethod (rcPtr, "finalize", NULL, NULL, + &res, &resObj, DO_CAPTURE); + + if ((res != TCL_OK) && (interp != NULL)) { + Tcl_SetChannelErrorInterp (interp, resObj); + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ +#ifdef TCL_THREADS + RcFree (rcPtr); + } +#endif + return (res == TCL_OK) ? EOK : EINVAL; + } + + Tcl_Panic ("Should not be reached"); + return EINVAL; +} + +/* + *---------------------------------------------------------------------- + * + * RcInput -- + * + * This function is invoked when more data is requested from the + * channel. + * + * Results: + * The number of bytes read. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcInput (clientData, buf, toRead, errorCodePtr) + 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' */ + + /* 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); + *errorCodePtr = EINVAL; + return -1; + } + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamInput p; + + p.buf = buf; + p.toRead = toRead; + + RcForwardOp (rcPtr, RcOpInput, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } + + return p.toRead; + } +#endif + + /* -------- */ + + /* 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 */ + *errorCodePtr = EINVAL; + return -1; + } + + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); + + if (toRead < bytec) { + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + RcSetChannelErrorStr (rcPtr->chan, msg_read_toomuch); + *errorCodePtr = EINVAL; + return -1; + } + + *errorCodePtr = EOK; + + if (bytec > 0) { + memcpy (buf, bytev, bytec); + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return bytec; +} + +/* + *---------------------------------------------------------------------- + * + * RcOutput -- + * + * This function is invoked when data is writen to the + * channel. + * + * Results: + * The number of bytes actually written. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcOutput (clientData, buf, toWrite, errorCodePtr) + 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; + + /* 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; + return -1; + } + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamOutput p; + + p.buf = buf; + p.toWrite = toWrite; + + RcForwardOp (rcPtr, RcOpOutput, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } + + return p.toWrite; + } +#endif + + /* -------- */ + + /* 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 */ + *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)); + *errorCodePtr = EINVAL; + return -1; + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the 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. + */ + + RcSetChannelErrorStr (rcPtr->chan, msg_write_toomuch); + *errorCodePtr = EINVAL; + return -1; + } + + *errorCodePtr = EOK; + return written; +} + +/* + *---------------------------------------------------------------------- + * + * RcSeekWide / RcSeek -- + * + * This function is invoked when the user wishes to seek on + * the channel. + * + * Results: + * The new location of the access point. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static Tcl_WideInt +RcSeekWide (clientData, offset, seekMode, errorCodePtr) + 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; + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamSeek p; + + p.seekMode = seekMode; + p.offset = offset; + + RcForwardOp (rcPtr, RcOpSeek, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + *errorCodePtr = EINVAL; + } else { + *errorCodePtr = EOK; + } + + return p.offset; + } +#endif + + /* -------- */ + + /* 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 */ + *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)); + *errorCodePtr = EINVAL; + return -1; + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + + if (newLoc < Tcl_LongAsWide (0)) { + RcSetChannelErrorStr (rcPtr->chan, msg_seek_beforestart); + *errorCodePtr = EINVAL; + return -1; + } + + *errorCodePtr = EOK; + return newLoc; +} + +static int +RcSeek (clientData, offset, seekMode, errorCodePtr) + 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); +} + +/* + *---------------------------------------------------------------------- + * + * RcWatch -- + * + * This function is invoked to tell the channel what events + * the I/O system is interested in. + * + * Results: + * None. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static void +RcWatch (clientData, mask) + ClientData clientData; + int mask; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* maskObj; + + /* ASSERT rcPtr->methods & FLAG (METH_WATCH) */ + + /* We restrict the interest to what the channel can support + * IOW there will never be write events for a channel which is + * not writable. Analoguous for read events. + */ + + mask = mask & rcPtr->mode; + + if (mask == rcPtr->interest) { + /* Same old, same old, why should we do something ? */ + return; + } + + rcPtr->interest = mask; + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamWatch p; + + p.mask = mask; + + RcForwardOp (rcPtr, RcOpWatch, rcPtr->thread, &p); + + /* 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); +} + +/* + *---------------------------------------------------------------------- + * + * RcBlock -- + * + * This function is invoked to tell the channel which blocking + * behaviour is required of it. + * + * Results: + * A posix error number. + * + * Side effects: + * Allocates memory. Arbitrary, as it calls upon a script. + * + *---------------------------------------------------------------------- + */ + +static int +RcBlock (clientData, nonblocking) + ClientData clientData; + int nonblocking; +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* blockObj; + int res; /* Result code for 'blocking' */ + Tcl_Obj* resObj; /* Result data for 'blocking' */ + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamBlock p; + + p.nonblocking = nonblocking; + + RcForwardOp (rcPtr, RcOpBlock, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + RcPassReceivedError (rcPtr->chan, p.b); + return EINVAL; + } else { + 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; + } else { + res = EOK; + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; +} + +/* + *---------------------------------------------------------------------- + * + * RcSetOption -- + * + * This function is invoked to configure a channel option. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + */ + +static int +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 */ +{ + ReflectingChannel* rcPtr = (ReflectingChannel*) clientData; + Tcl_Obj* optionObj; + Tcl_Obj* valueObj; + int res; /* Result code for 'configure' */ + Tcl_Obj* resObj; /* Result data for 'configure' */ + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + RcForwardParamSetOpt p; + + p.name = optionName; + p.value = newValue; + + RcForwardOp (rcPtr, RcOpSetOpt, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); + + RcErrorReturn (interp, err); + + Tcl_DecrRefCount (err); + if (p.b.vol) {ckfree (p.b.msg);} + } + + return p.b.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); + } + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; +} + +/* + *---------------------------------------------------------------------- + * + * RcGetOption -- + * + * This function is invoked to retrieve all or a channel option. + * + * Results: + * A standard Tcl result code. + * + * Side effects: + * Arbitrary, as it calls upon a Tcl script. + * + *---------------------------------------------------------------------- + */ + +static int +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 */ +{ + /* 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; + +#ifdef TCL_THREADS + /* Are we in the correct thread ? + */ + + if (rcPtr->thread != Tcl_GetCurrentThread ()) { + int opcode; + RcForwardParamGetOpt p; + + p.name = optionName; + p.value = dsPtr; + + if (optionName == (char*) NULL) { + opcode = RcOpGetOptAll; + } else { + opcode = RcOpGetOpt; + } + + RcForwardOp (rcPtr, opcode, rcPtr->thread, &p); + + if (p.b.code != TCL_OK) { + Tcl_Obj* err = Tcl_NewStringObj (p.b.msg, -1); + + RcErrorReturn (interp, err); + + Tcl_DecrRefCount (err); + if (p.b.vol) {ckfree (p.b.msg);} + } + + return p.b.code; + } +#endif + + /* -------- */ + + if (optionName == (char*) NULL) { + /* Retrieve all options. */ + 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"); + } + } + + RcInvokeTclMethod (rcPtr, method, optionObj, NULL, + &res, &resObj, DO_CAPTURE); + + if (res != TCL_OK) { + RcErrorReturn (interp, resObj); + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; + } + + /* 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; + } + + /* 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): --- + */ + + res = Tcl_ListObjGetElements (interp, resObj, &listc, &listv); + + if (res != TCL_OK) { + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; + } + + if ((listc % 2) == 1) { + /* Odd number of elements is wrong. + */ + + char buf [20]; + + sprintf (buf, "%d", listc); + Tcl_ResetResult (interp); + Tcl_AppendResult (interp, + "Expected list with even number of elements, got ", + buf, (listc == 1 ? " element" : " elements"), + " instead", (char*) NULL); + + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return TCL_ERROR; + } + + + { + int len; + char* str = Tcl_GetStringFromObj (resObj, &len); + + if (len) { + Tcl_DStringAppend (dsPtr, " ", 1); + Tcl_DStringAppend (dsPtr, str, len); + } + } + Tcl_DecrRefCount (resObj); /* Remove reference we held from the invoke */ + return res; +} + +/* + * Helpers. ========================================================= + */ + +/* + *---------------------------------------------------------------------- + * + * RcEncodeEventMask -- + * + * 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. + * + * Results: + * A standard Tcl error code. A bitmask where TCL_READABLE + * and/or TCL_WRITABLE can be set. + * + * Side effects: + * May shimmer 'obj' to a list representation. May place an + * error message into the interp result. + * + *---------------------------------------------------------------------- + */ + +static int +RcEncodeEventMask (interp, objName, obj, mask) + Tcl_Interp* interp; + CONST char* objName; + Tcl_Obj* obj; + int* mask; +{ + int events; /* Mask of events to post */ + int listc; /* #elements in eventspec list */ + Tcl_Obj** listv; /* Elements of eventspec list */ + int evIndex; /* Id of event for an element of the + * eventspec list */ + + if (Tcl_ListObjGetElements (interp, obj, + &listc, &listv) != TCL_OK) { + return TCL_ERROR; + } + + if (listc < 1) { + Tcl_AppendResult(interp, "bad ", objName, " list: is empty", + (char *) NULL); + return TCL_ERROR; + } + + events = 0; + while (listc > 0) { + if (Tcl_GetIndexFromObj (interp, listv [listc-1], + eventOptions, objName, 0, &evIndex) != TCL_OK) { + return TCL_ERROR; + } + switch (evIndex) { + case EVENT_READ: events |= TCL_READABLE; break; + case EVENT_WRITE: events |= TCL_WRITABLE; break; + } + listc --; + } + + *mask = events; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * RcDecodeEventMask -- + * + * This function takes an internal bitmask of events and + * constructs the equivalent list of event items. + * + * Results: + * A Tcl_Obj reference. The object will have a refCount of + * one. The user has to decrement it to release the object. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static Tcl_Obj* +RcDecodeEventMask (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"); + } + + Tcl_IncrRefCount (evObj); + return evObj; +} + +/* + *---------------------------------------------------------------------- + * + * RcNew -- + * + * This function is invoked to allocate and initialize the + * instance data of a new reflected channel. + * + * Results: + * A heap-allocated channel instance. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +static ReflectingChannel* +RcNew (interp, cmdpfxObj, mode, id) + Tcl_Interp* interp; + Tcl_Obj* cmdpfxObj; + int mode; + Tcl_Obj* id; +{ + ReflectingChannel* rcPtr; + int listc; + Tcl_Obj** listv; + Tcl_Obj* word; + int i; + + rcPtr = (ReflectingChannel*) ckalloc (sizeof(ReflectingChannel)); + + /* 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; +#ifdef TCL_THREADS + rcPtr->thread = Tcl_GetCurrentThread (); +#endif + rcPtr->mode = mode; + rcPtr->interest = 0; /* Initially no interest registered */ + + /* Method placeholder */ + + /* ASSERT: cmdpfxObj is a Tcl List */ + + Tcl_ListObjGetElements (interp, cmdpfxObj, &listc, &listv); + + /* See [==] as well. + * Storage for the command prefix and the additional words required + * for the invocation of methods in the command handler. + * + * listv [0] [listc-1] | [listc] [listc+1] | + * argv [0] ... [.] | [argc-2] [argc-1] | [argc] [argc+2] + * cmd ... pfx | method chan | detail1 detail2 + */ + + rcPtr->argc = listc + 2; + rcPtr->argv = (Tcl_Obj**) ckalloc (sizeof (Tcl_Obj*) * (listc+4)); + + for (i = 0; i < listc ; i++) { + word = rcPtr->argv [i] = listv [i]; + Tcl_IncrRefCount (word); + } + + i++; /* Skip placeholder for method */ + + rcPtr->argv [i] = id ; Tcl_IncrRefCount (id); + + /* The next two objects are kept empty, varying arguments */ + + /* Initialization complete */ + return rcPtr; +} + +/* + *---------------------------------------------------------------------- + * + * RcNewHandle -- + * + * This function is invoked to generate a channel handle for + * a new reflected channel. + * + * Results: + * A Tcl_Obj containing the string of the new channel handle. + * The refcount of the returned object is -- zero --. + * + * Side effects: + * May allocate memory. Mutex protected critical section + * locks out other threads for a short time. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj* +RcNewHandle () +{ + /* 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 + static unsigned long rcCounter = 0; + + char channelName [50]; + Tcl_Obj* res = Tcl_NewStringObj ("rc", -1); + +#ifdef TCL_THREADS + Tcl_MutexLock (&rcCounterMutex); +#endif + + sprintf (channelName, "%lu", (unsigned long) rcCounter); + rcCounter ++; + +#ifdef TCL_THREADS + Tcl_MutexUnlock (&rcCounterMutex); +#endif + + Tcl_AppendStringsToObj (res, channelName, (char*) NULL); + return res; +} + + +static void +RcFree (rcPtr) + ReflectingChannel* rcPtr; +{ + Channel* chanPtr = (Channel*) rcPtr->chan; + int i, n; + + if (chanPtr->typePtr != &tclRChannelType) { + /* Delete a cloned ChannelType structure. */ + ckfree ((char*) chanPtr->typePtr); + } + + n = rcPtr->argc - 2; + for (i = 0; i < n; i++) { + Tcl_DecrRefCount (rcPtr->argv[i]); + } + + ckfree ((char*) rcPtr->argv); + ckfree ((char*) rcPtr); + return; +} + +/* + *---------------------------------------------------------------------- + * + * RcInvokeTclMethod -- + * + * 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. + * + * Results: + * Result code and data as returned by the method. + * + * Side effects: + * Arbitrary, as it calls upo na 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; +{ + /* 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. */ + + /* 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): --- + */ + + /* 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; + + /* 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++; + } + + /* 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); + + /* 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 + * is no capture. + */ + + 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. + */ + + res = TCL_ERROR; + resObj = RcErrorMarshall (rcPtr->interp); + } + Tcl_IncrRefCount(resObj); + } + Tcl_RestoreInterpState (rcPtr->interp, sr); + + /* ... */ + + /* Cleanup of the dynamic parts of the command */ + + Tcl_DecrRefCount (methObj); + if (argone) {Tcl_DecrRefCount (argone);} + if (argtwo) {Tcl_DecrRefCount (argtwo);} + + /* 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). + */ + + if (result) { + *result = res; + } + if (resultObj) { + *resultObj = resObj; + } + /* There no need to handle the case where nothing is returned, because for + * that case resObj was not set anyway. + */ +} + +#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 */ +{ + RcForwardingEvent* evPtr; + RcForwardingResult* resultPtr; + int result; + + /* Create and initialize the event and data structures */ + + evPtr = (RcForwardingEvent*) ckalloc (sizeof (RcForwardingEvent)); + resultPtr = (RcForwardingResult*) ckalloc (sizeof (RcForwardingResult)); + + evPtr->event.proc = RcForwardProc; + 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->result = -1; + resultPtr->evPtr = evPtr; + + /* 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. + */ + + Tcl_CreateThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); + Tcl_CreateThreadExitHandler(RcDstExitProc, (ClientData) evPtr); + + /* + * Queue the event and poke the other thread's notifier. + */ + + Tcl_ThreadQueueEvent(dst, (Tcl_Event*)evPtr, TCL_QUEUE_TAIL); + Tcl_ThreadAlert(dst); + + /* + * (*) Block until the other thread has either processed the transfer + * or rejected it. + */ + + while (resultPtr->result < 0) { + /* NOTE (1): Is it possible that the current thread goes away while waiting here ? + * NOTE (1): IOW Is it possible that "RcSrcExitProc" is called while we are here ? + * NOTE (1): See complementary note (2) in "RcSrcExitProc" + * NOTE (1): --- + */ + + Tcl_ConditionWait(&resultPtr->done, &rcForwardMutex, NULL); + } + + /* + * Unlink result from the forwarder list. + */ + + TclSpliceOut(resultPtr, forwardList); + + 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. + * + * Note: The event structure has already been deleted. + */ + + Tcl_DeleteThreadExitHandler(RcSrcExitProc, (ClientData) evPtr); + Tcl_DeleteThreadExitHandler(RcDstExitProc, (ClientData) evPtr); + + result = resultPtr->result; + ckfree ((char*) resultPtr); +} + +static int +RcForwardProc (evGPtr, mask) + Tcl_Event *evGPtr; + int mask; +{ + /* Notes regarding access to the referenced data. + * + * In principle the data belongs to the originating thread (see + * evPtr->src), however this thread is currently blocked at (*), + * i.e. quiescent. Because of this we can treat the data as + * belonging to us, without fear of race conditions. I.e. we can + * read and write as we like. + * + * The only thing we cannot be sure of is the resultPtr. This can be + * be NULLed if the originating thread went away while the event + * is handled here now. + */ + + 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 */ + + /* Ignore the event if no one is waiting for its result anymore. + */ + + if (!resultPtr) { + return 1; + } + + paramPtr->code = TCL_OK; + paramPtr->msg = NULL; + paramPtr->vol = 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; + + default: + /* Bad operation code */ + Tcl_Panic ("Bad operation code in RcForwardProc"); + break; + } + + /* Remove the reference we held on the result of the invoke, if we had + * such + */ + if (resObj != NULL) { + Tcl_DecrRefCount (resObj); + } + + if (resultPtr) { + /* + * Report the forwarding result synchronously to the waiting + * caller. This unblocks (*) as well. This is wrapped into a + * conditional because the caller may have exited in the mean + * time. + */ + + Tcl_MutexLock(&rcForwardMutex); + resultPtr->result = TCL_OK; + Tcl_ConditionNotify(&resultPtr->done); + Tcl_MutexUnlock(&rcForwardMutex); + } + + return 1; +} + + +static void +RcSrcExitProc (clientData) + ClientData clientData; +{ + RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; + RcForwardingResult* resultPtr; + RcForwardParamBase* paramPtr; + + /* NOTE (2): Can this handler be called with the originator blocked ? + * NOTE (2): --- + */ + + /* 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 "RcForwardProc", should it already execute the + * event. + */ + + Tcl_MutexLock(&rcForwardMutex); + + resultPtr = evPtr->resultPtr; + paramPtr = (RcForwardParamBase*) evPtr->param; + + evPtr->resultPtr = NULL; + resultPtr->evPtr = NULL; + resultPtr->result = TCL_ERROR; + + RcForwardSetStaticError (paramPtr, msg_send_originlost); + + /* See below: TclSpliceOut(resultPtr, forwardList); */ + + Tcl_MutexUnlock(&rcForwardMutex); + + /* + * This unlocks (*). The structure will be spliced out and freed by + * "RcForwardProc". Maybe. + */ + + Tcl_ConditionNotify(&resultPtr->done); +} + + +static void +RcDstExitProc (clientData) + ClientData clientData; +{ + RcForwardingEvent* evPtr = (RcForwardingEvent*) clientData; + RcForwardingResult* resultPtr = evPtr->resultPtr; + RcForwardParamBase* paramPtr = (RcForwardParamBase*) 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): --- + */ + + /* 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; + + RcForwardSetStaticError (paramPtr, msg_send_dstlost); + + Tcl_ConditionNotify(&resultPtr->done); +} + + +static void +RcForwardSetObjError (p,obj) + RcForwardParamBase* p; + Tcl_Obj* obj; +{ + int len; + char* msg; + + msg = Tcl_GetStringFromObj (obj, &len); + + p->code = TCL_ERROR; + p->vol = 1; + p->msg = strcpy(ckalloc (1+len), msg); +} +#endif + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclInt.h b/generic/tclInt.h index 8ba85b6..1da1a43 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.245 2005/08/11 22:06:47 kennykb Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.246 2005/08/24 17:56:23 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1515,6 +1515,15 @@ typedef struct Interp { * inserted by an ensemble. */ } ensembleRewrite; + /* TIP #219 ... Global info for the I/O system ... + * Error message set by channel drivers, for the propagation of + * arbitrary Tcl errors. This information, if present (chanMsg not + * NULL), takes precedence over a posix error code returned by a + * channel operation. + */ + + Tcl_Obj* chanMsg; + /* * Statistical information about the bytecode compiler and interpreter's * operation. @@ -1527,6 +1536,42 @@ typedef struct Interp { } Interp; /* + * General list of interpreters. Doubly linked for easier + * removal of items deep in the list. + */ + +typedef struct InterpList { + Interp* interpPtr; + struct InterpList* prevPtr; + struct InterpList* nextPtr; +} InterpList; + +/* + * Macros for splicing into and out of doubly linked lists. + * They assume existence of struct items 'prevPtr' and 'nextPtr'. + * + * a = element to add or remove. + * b = list head. + * + * TclSpliceIn adds to the head of the list. + */ + +#define TclSpliceIn(a,b) \ + (a)->nextPtr = (b); \ + if ((b) != NULL) \ + (b)->prevPtr = (a); \ + (a)->prevPtr = NULL, (b) = (a); + +#define TclSpliceOut(a,b) \ + if ((a)->prevPtr != NULL) \ + (a)->prevPtr->nextPtr = (a)->nextPtr; \ + else \ + (b) = (a)->nextPtr; \ + if ((a)->nextPtr != NULL) \ + (a)->nextPtr->prevPtr = (a)->prevPtr; + + +/* * EvalFlag bits for Interp structures: * * TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with @@ -1941,6 +1986,12 @@ MODULE_SCOPE int TclArraySet _ANSI_ARGS_((Tcl_Interp *interp, MODULE_SCOPE double TclBignumToDouble _ANSI_ARGS_((mp_int* bignum)); MODULE_SCOPE int TclCheckBadOctal _ANSI_ARGS_((Tcl_Interp *interp, CONST char *value)); +MODULE_SCOPE int TclChanCreateObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +MODULE_SCOPE int TclChanPostEventObjCmd _ANSI_ARGS_((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); +MODULE_SCOPE int TclChanCaughtErrorBypass _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Channel chan)); MODULE_SCOPE void TclCleanupLiteralTable _ANSI_ARGS_(( Tcl_Interp* interp, LiteralTable* tablePtr)); MODULE_SCOPE int TclDoubleDigits _ANSI_ARGS_((char* buf, diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 5efadc4..b27ab3d 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStubInit.c,v 1.121 2005/08/05 23:57:36 dkf Exp $ + * RCS: @(#) $Id: tclStubInit.c,v 1.122 2005/08/24 17:56:23 andreas_kupries Exp $ */ #include "tclInt.h" @@ -984,6 +984,10 @@ TclStubs tclStubs = { Tcl_GetBignumFromObj, /* 558 */ Tcl_TruncateChannel, /* 559 */ Tcl_ChannelTruncateProc, /* 560 */ + Tcl_SetChannelErrorInterp, /* 561 */ + Tcl_GetChannelErrorInterp, /* 562 */ + Tcl_SetChannelError, /* 563 */ + Tcl_GetChannelError, /* 564 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclTest.c b/generic/tclTest.c index 974112c..d0f6406 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTest.c,v 1.91 2005/06/01 21:38:42 dgp Exp $ + * RCS: @(#) $Id: tclTest.c,v 1.92 2005/08/24 17:56:23 andreas_kupries Exp $ */ #define TCL_TEST @@ -121,6 +121,20 @@ typedef struct TestEvent { Tcl_Obj* tag; /* Tag for this event used to delete it */ } TestEvent; + +/* + * Simple detach/attach facility for testchannel cut|splice. + * Allow testing of channel transfer in core testsuite. + */ + +typedef struct TestChannel { + Tcl_Channel chan; /* Detached channel */ + struct TestChannel* nextPtr; /* Next in pool of detached channels */ +} TestChannel; + +static TestChannel* firstDetached; + + /* * Forward declarations for procedures defined later in this file: */ @@ -5352,10 +5366,33 @@ TestChannelCmd(clientData, interp, argc, argv) chanPtr = (Channel *) NULL; if (argc > 2) { - chan = Tcl_GetChannel(interp, argv[2], &mode); - if (chan == (Tcl_Channel) NULL) { - return TCL_ERROR; - } + if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { + /* For splice access the pool of detached channels. + * Locate channel, remove from the list. + */ + + TestChannel** nextPtrPtr; + TestChannel* curPtr; + + chan = (Tcl_Channel) NULL; + for (nextPtrPtr = &firstDetached, curPtr = firstDetached; + curPtr != NULL; + nextPtrPtr = &(curPtr->nextPtr), curPtr = curPtr->nextPtr) { + + if (strcmp (argv[2], Tcl_GetChannelName (curPtr->chan)) == 0) { + *nextPtrPtr = curPtr->nextPtr; + curPtr->nextPtr = NULL; + chan = curPtr->chan; + ckfree ((char*) curPtr); + break; + } + } + } else { + chan = Tcl_GetChannel(interp, argv[2], &mode); + } + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } chanPtr = (Channel *) chan; statePtr = chanPtr->state; chanPtr = statePtr->topChanPtr; @@ -5366,13 +5403,62 @@ TestChannelCmd(clientData, interp, argc, argv) chan = NULL; } + if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerror", len) == 0)) { + + Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); + + Tcl_IncrRefCount (msg); + Tcl_SetChannelError (chan, msg); + Tcl_DecrRefCount (msg); + + Tcl_GetChannelError (chan, &msg); + Tcl_SetObjResult (interp, msg); + Tcl_DecrRefCount (msg); + return TCL_OK; + } + if ((cmdName[0] == 's') && (strncmp(cmdName, "setchannelerrorinterp", len) == 0)) { + + Tcl_Obj* msg = Tcl_NewStringObj (argv [3],-1); + + Tcl_IncrRefCount (msg); + Tcl_SetChannelErrorInterp (interp, msg); + Tcl_DecrRefCount (msg); + + Tcl_GetChannelErrorInterp (interp, &msg); + Tcl_SetObjResult (interp, msg); + Tcl_DecrRefCount (msg); + return TCL_OK; + } + + /* + * "cut" is actually more a simplified detach facility as provided + * by the Thread package. Without the safeguards of a regular + * command (no checking that the command is truly cut'able, no + * mutexes for thread-safety). Its complementary command is + * "splice", see below. + */ + if ((cmdName[0] == 'c') && (strncmp(cmdName, "cut", len) == 0)) { + TestChannel* det; + if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " cut channelName\"", (char *) NULL); return TCL_ERROR; } + + Tcl_RegisterChannel((Tcl_Interp *) NULL, chan); /* prevent closing */ + Tcl_UnregisterChannel(interp, chan); + Tcl_CutChannel(chan); + + /* Remember the channel in the pool of detached channels */ + + det = (TestChannel*) ckalloc (sizeof(TestChannel)); + det->chan = chan; + det->nextPtr = firstDetached; + firstDetached = det; + return TCL_OK; } @@ -5626,6 +5712,14 @@ TestChannelCmd(clientData, interp, argc, argv) return TCL_OK; } + /* + * "splice" is actually more a simplified attach facility as + * provided by the Thread package. Without the safeguards of a + * regular command (no checking that the command is truly + * cut'able, no mutexes for thread-safety). Its complementary + * command is "cut", see above. + */ + if ((cmdName[0] == 's') && (strncmp(cmdName, "splice", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", (char *) NULL); @@ -5633,6 +5727,10 @@ TestChannelCmd(clientData, interp, argc, argv) } Tcl_SpliceChannel(chan); + + Tcl_RegisterChannel(interp, chan); + Tcl_UnregisterChannel((Tcl_Interp *)NULL, chan); + return TCL_OK; } @@ -6672,3 +6770,11 @@ TestgetintCmd(dummy, interp, argc, argv) return TCL_OK; } } + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 299a5aa..21487e7 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadTest.c,v 1.19 2005/05/10 18:34:50 kennykb Exp $ + * RCS: @(#) $Id: tclThreadTest.c,v 1.20 2005/08/24 17:56:23 andreas_kupries Exp $ */ #include "tclInt.h" @@ -479,6 +479,12 @@ NewTestThread(clientData) result = Tcl_Init(tsdPtr->interp); result = TclThread_Init(tsdPtr->interp); + /* This is part of the test facility. + * Initialize _ALL_ test commands for + * use by the new thread. + */ + result = Tcltest_Init(tsdPtr->interp); + /* * Update the list of threads. */ |