summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tcl.decls17
-rw-r--r--generic/tclBasic.c23
-rw-r--r--generic/tclDecls.h46
-rw-r--r--generic/tclIO.c469
-rw-r--r--generic/tclIO.h16
-rw-r--r--generic/tclIOCmd.c95
-rw-r--r--generic/tclIORChan.c2668
-rw-r--r--generic/tclInt.h53
-rw-r--r--generic/tclStubInit.c6
-rw-r--r--generic/tclTest.c116
-rw-r--r--generic/tclThreadTest.c8
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.
*/