diff options
| -rw-r--r-- | ChangeLog | 28 | ||||
| -rw-r--r-- | doc/SetChanErr.3 | 155 | ||||
| -rw-r--r-- | generic/tcl.decls | 17 | ||||
| -rw-r--r-- | generic/tclBasic.c | 23 | ||||
| -rw-r--r-- | generic/tclDecls.h | 46 | ||||
| -rw-r--r-- | generic/tclIO.c | 469 | ||||
| -rw-r--r-- | generic/tclIO.h | 16 | ||||
| -rw-r--r-- | generic/tclIOCmd.c | 95 | ||||
| -rw-r--r-- | generic/tclIORChan.c | 2668 | ||||
| -rw-r--r-- | generic/tclInt.h | 53 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 6 | ||||
| -rw-r--r-- | generic/tclTest.c | 116 | ||||
| -rw-r--r-- | generic/tclThreadTest.c | 8 | ||||
| -rw-r--r-- | library/init.tcl | 39 | ||||
| -rw-r--r-- | tests/chan.test | 9 | ||||
| -rw-r--r-- | tests/io.test | 277 | ||||
| -rw-r--r-- | tests/ioCmd.test | 3078 | ||||
| -rw-r--r-- | unix/Makefile.in | 8 | ||||
| -rw-r--r-- | win/Makefile.in | 3 | ||||
| -rw-r--r-- | win/makefile.vc | 3 |
20 files changed, 7028 insertions, 89 deletions
@@ -1,3 +1,31 @@ +2005-08-24 Andreas Kupries <andreask@activestate.com> + + TIP#219 IMPLEMENTATION + + * doc/SetChanErr.3: ** New File **. Documentation of the new + channel API functions. + * generic/tcl.decls: Stub declarations of the new channel API. + * generic/tclDecls.h: Regenerated + * generic/tclStubInit.c: + + * tclIORChan.c: ** New File **. Implementation of the reflected + channel. + * generic/tclInt.h: Integration of reflected channel and new error + * generic/tclIO.c: propagation into the generic I/O core. + * generic/tclIOCmd.c: + * generic/tclIO.h: + * library/init.tcl: + + * tests/io.test: Extended testsuite. + * tests/ioCmd.test: + * tests/chan.test: + * generic/tclTest.c: + * generic/tclThreadTest.c: + + * unix/Makefile.in: Integration into the build machinery. + * win/Makefile.in: + * win/Makefile.vc: + 2005-08-24 Kevin Kenny <kennykb@acm.org> * generic/tclStrToD.c (Tcl_DoubleDigits): Fixed the corner cases of diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3 new file mode 100644 index 0000000..881768f --- /dev/null +++ b/doc/SetChanErr.3 @@ -0,0 +1,155 @@ +'\" +'\" Copyright (c) 2005 Andreas Kupries <andreas_kupries@users.sourceforge.net> +'\" +'\" See the file "license.terms" for information on usage and redistribution +'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. +'\" +'\" RCS: @(#) $Id: SetChanErr.3,v 1.1 2005/08/24 17:56:23 andreas_kupries Exp $ +.so man.macros +.TH Tcl_SetChannelError 3 8.5 Tcl "Tcl Library Procedures" +.BS +'\" Note: do not modify the .SH NAME line immediately below! +.SH NAME +Tcl_SetChannelError, Tcl_SetChannelErrorInterp, Tcl_GetChannelError, Tcl_GetChannelErrorInterp \- functions to create/intercept Tcl errors by channel drivers. +.SH SYNOPSIS +.nf +\fB#include <tcl.h>\fR +.sp +void +\fBTcl_SetChannelError\fR(\fIchan, msg\fR) +.sp +void +\fBTcl_SetChannelErrorInterp\fR(\fIinterp, msg\fR) +.sp +void +\fBTcl_GetChannelError\fR(\fIchan, msgPtr\fR) +.sp +void +\fBTcl_GetChannelErrorInterp\fR(\fIinterp, msgPtr\fR) +.sp +.SH ARGUMENTS +.AS Tcl_Channel chan +.AP Tcl_Channel chan in +Refers to the Tcl channel whose bypass area is accessed. +.AP Tcl_Interp* interp in +Refers to the Tcl interpreter whose bypass area is accessed. +.AP Tcl_Obj* msg in +Error message put into a bypass area. A list of return options and +values, followed by a string message. Both message and the +option/value information are optional. +.AP Tcl_Obj** msgPtr out +Reference to a place where the message stored in the accessed bypass +area can be stored in. +.BE +.SH DESCRIPTION +.PP +The current definition of a Tcl channel driver does not permit the +direct return of arbitrary error messages, except for the setting and +retrieval of channel options. All other functions are restricted to +POSIX error codes. +.PP +The functions described here overcome this limitation. Channel drivers +are allowed to use \fBTcl_SetChannelError\fR and +\fBTcl_SetChannelErrorInterp\fR to place arbitrary error messages in +\fBbypass areas\fI defined for channels and interpreters. And the +generic I/O layer uses \fBTcl_GetChannelError\fR and +\fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass +areas and arrange for their return as errors. The posix error codes +set by a driver are used now if and only if no messages are present. +.PP +\fBTcl_SetChannelError\fR stores error information in the bypass area +of the specified channel. The number of references to the \fBmsg\fI +object goes up by one. Previously stored information will be +discarded, by releasing the reference held by the channel. The channel +reference must not be NULL. +.PP +\fBTcl_SetChannelErrorInterp\fR stores error information in the bypass +area of the specified interpreter. The number of references to the +\fBmsg\fI object goes up by one. Previously stored information will be +discarded, by releasing the reference held by the interpreter. The +interpreter reference must not be NULL. +.PP +\fBTcl_GetChannelError\fR places either the error message held in the +bypass area of the specified channel into \fImsgPtr\fR, or NULL; and +resets the bypass. I.e. after an invokation all following invokations +will return NULL, until an intervening invokation of +\fBTcl_SetChannelError\fR with a non-NULL message. The \fImsgPtr\fR +must not be NULL. The reference count of the message is not touched. +The reference previously held by the channel is now held by the caller +of the function and it is its responsibility to release that reference +when it is done with the object. +.PP +\fBTcl_GetChannelErrorInterp\fR places either the error message held +in the bypass area of the specified interpreter into \fImsgPtr\fR, or +NULL; and resets the bypass. I.e. after an invokation all following +invokations will return NULL, until an intervening invokation of +\fBTcl_SetChannelErrorInterp\fR with a non-NULL message. The +\fImsgPtr\fR must not be NULL. The reference count of the message is +not touched. The reference previously held by the interpreter is now +held by the caller of the function and it is its responsibility to +release that reference when it is done with the object. +.PP +Which functions of a channel driver are allowed to use which bypass +function is listed below, as is which functions of the public channel +API may leave a messages in the bypass areas. +.PP +.IP \fBTcl_DriverCloseProc\fR +May use \fBTcl_SetChannelErrorInterp\fR, and only this function. +.IP \fBTcl_DriverInputProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverOutputProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverSeekProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverWideSeekProc +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverSetOptionProc\fR +Has already the ability to pass arbitrary error messages. Must +\fBnot\fR use any of the new functions. +.IP \fBTcl_DriverGetOptionProc\fR +Has already the ability to pass arbitrary error messages. Must +\fBnot\fR use any of the new functions. +.IP \fBTcl_DriverWatchProc\fR +Must \fBnot\fR use any of the new functions. Is internally called and +has no ability to return any type of error whatsoever. +.IP \fBTcl_DriverBlockModeProc\fR +May use \fBTcl_SetChannelError\fR, and only this function. +.IP \fBTcl_DriverGetHandleProc\fR +Must \fBnot\fR use any of the new functions. It is only a low-level +function, and not used by Tcl commands. +.IP \fBTcl_DriverHandlerProc\fR +Must \fBnot\fR use any of the new functions. Is internally called and +has no ability to return any type of error whatsoever. +.PP +Given the information above the following public functions of the Tcl +C API are affected by these changes. I.e. when these functions are +called the channel may now contain a stored arbitrary error message +requiring processing by the caller. +.PP +.IP \fBTcl_StackChannel\fR +.IP \fBTcl_Seek\fR +.IP \fBTcl_Tell\fR +.IP \fBTcl_ReadRaw\fR +.IP \fBTcl_Read\fR +.IP \fBTcl_ReadChars\fR +.IP \fBTcl_Gets\fR +.IP \fBTcl_GetsObj\fR +.IP \fBTcl_Flush\fR +.IP \fBTcl_WriteRaw\fR +.IP \fBTcl_WriteObj\fR +.IP \fBTcl_Write\fR +.IP \fBTcl_WriteChars\fR +.PP +All other API functions are unchanged. Especially the functions below +leave all their error information in the interpreter result. +.PP +.IP \fBTcl_Close\fR +.IP \fBTcl_UnregisterChannel\fR +.IP \fBTcl_UnstackChannel\fR +.PP + +.SH "SEE ALSO" +Tcl_Close(3), Tcl_OpenFileChannel(3), Tcl_SetErrno(3) + +.SH KEYWORDS +channel driver, error messages, channel type 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. */ diff --git a/library/init.tcl b/library/init.tcl index 626f9f3..527f0b9 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.79 2005/07/27 16:24:14 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.80 2005/08/24 17:56:23 andreas_kupries Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -73,24 +73,27 @@ namespace eval tcl { unsupported::EncodingDirs $Path } - # Set up the 'chan' ensemble + # Set up the 'chan' ensemble (TIP #208). namespace eval chan { - namespace ensemble create -command ::chan -map { - blocked ::fblocked - close ::close - configure ::fconfigure - copy ::fcopy - eof ::eof - event ::fileevent - flush ::flush - gets ::gets - names {::file channels} - puts ::puts - read ::read - seek ::seek - tell ::tell - truncate ::tcl::chan::Truncate - } + # TIP #219. Added methods: create, postevent. + namespace ensemble create -command ::chan -map { + blocked ::fblocked + close ::close + configure ::fconfigure + copy ::fcopy + create ::tcl::chan::rCreate + eof ::eof + event ::fileevent + flush ::flush + gets ::gets + names {::file channels} + postevent ::tcl::chan::rPostevent + puts ::puts + read ::read + seek ::seek + tell ::tell + truncate ::tcl::chan::Truncate + } } } diff --git a/tests/chan.test b/tests/chan.test index dd2fea6..f2376a3 100644 --- a/tests/chan.test +++ b/tests/chan.test @@ -7,19 +7,24 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: chan.test,v 1.4 2005/06/07 21:31:53 dkf Exp $ +# RCS: @(#) $Id: chan.test,v 1.5 2005/08/24 17:56:24 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +# +# Note: The tests for the chan methods "create" and "postevent" +# currently reside in the file "ioCmd.test". +# + test chan-1.1 {chan command general syntax} -body { chan } -returnCodes error -result "wrong # args: should be \"chan subcommand ?argument ...?\"" test chan-1.2 {chan command general syntax} -body { chan FOOBAR -} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, eof, event, flush, gets, names, puts, read, seek, tell, or truncate" +} -returnCodes error -result "unknown or ambiguous subcommand \"FOOBAR\": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate" test chan-2.1 {chan command: blocked subcommand} -body { chan blocked foo bar diff --git a/tests/io.test b/tests/io.test index 9d724b8..4edb308 100644 --- a/tests/io.test +++ b/tests/io.test @@ -1,3 +1,4 @@ +# -*- tcl -*- # Functionality covered: operation of all IO commands, and all procedures # defined in generic/tclIO.c. # @@ -12,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: io.test,v 1.68 2005/05/10 18:35:21 kennykb Exp $ +# RCS: @(#) $Id: io.test,v 1.69 2005/08/24 17:56:24 andreas_kupries Exp $ if {[catch {package require tcltest 2}]} { puts stderr "Skipping tests in [info script]. tcltest 2 required." @@ -28,14 +29,14 @@ namespace eval ::tcl::test::io { namespace import ::tcltest::testConstraint namespace import ::tcltest::viewFile -testConstraint testchannel [llength [info commands testchannel]] -testConstraint exec [llength [info commands exec]] -testConstraint openpipe 1 -testConstraint fileevent [llength [info commands fileevent]] -testConstraint fcopy [llength [info commands fcopy]] -testConstraint testfevent [llength [info commands testfevent]] +testConstraint testchannel [llength [info commands testchannel]] +testConstraint exec [llength [info commands exec]] +testConstraint openpipe 1 +testConstraint fileevent [llength [info commands fileevent]] +testConstraint fcopy [llength [info commands fcopy]] +testConstraint testfevent [llength [info commands testfevent]] testConstraint testchannelevent [llength [info commands testchannelevent]] -testConstraint testmainthread [llength [info commands testmainthread]] +testConstraint testmainthread [llength [info commands testmainthread]] # You need a *very* special environment to do some tests. In # particular, many file systems do not support large-files... @@ -7111,6 +7112,266 @@ test io-61.1 {Reset eof state after changing the eof char} -setup { removeFile eofchar } -result {77 = 23431} + +# Test the cutting and splicing of channels, this is incidentially the +# attach/detach facility of package Thread, but __without any +# safeguards__. It can also be used to emulate transfer of channels +# between threads, and is used for that here. + +test io-70.0 {Cutting & Splicing channels} {testchannel} { + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res {} + lappend res [catch {seek $c 0 start}] + testchannel cut $c + + lappend res [catch {seek $c 0 start}] + testchannel splice $c + + lappend res [catch {seek $c 0 start}] + close $c + + removeFile cutsplice + + set res +} {0 1 0} + + +# Duplicate of code in "thread.test". Find a better way of doing this +# without duplication. Maybe placement into a proc which transforms to +# nop after the first call, and placement of its defintion in a +# central location. + +testConstraint testthread [expr {[info commands testthread] != {}}] + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + + proc ThreadNullError {id info} { + # ignore + } +} + +test io-70.1 {Transfer channel} {testchannel testthread} { + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res {} + lappend res [catch {seek $c 0 start}] + testchannel cut $c + lappend res [catch {seek $c 0 start}] + + set tid [testthread create] + testthread send $tid [list set c $c] + lappend res [testthread send $tid { + testchannel splice $c + set res [catch {seek $c 0 start}] + close $c + set res + }] + + tcltest::threadReap + removeFile cutsplice + + set res +} {0 1 0} + +# ### ### ### ######### ######### ######### + +foreach {n msg expected} { + 0 {} {} + 1 {{message only}} {{message only}} + 2 {-options x} {-options x} + 3 {-options {x y} {the message}} {-options {x y} {the message}} + + 4 {-code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 5 {-code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 6 {-code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 7 {-code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 8 {-code error -level 0 -f ba snarf} {-code error -level 0 -f ba snarf} + 9 {-code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 10 {-code error -level 5 -f ba snarf} {-code error -level 0 -f ba snarf} + 11 {-code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 12 {-code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 13 {-code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 14 {-code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + 15 {-code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 16 {-code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + 17 {-code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 18 {-code error -level 0 -f ba} {-code error -level 0 -f ba} + 19 {-code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 20 {-code error -level 5 -f ba} {-code error -level 0 -f ba} + 21 {-code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 22 {-code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 23 {-code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 24 {-code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 25 {-code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 26 {-code error -level X -f ba snarf} {-code error -level 0 -f ba snarf} + 27 {-code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 28 {-code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 29 {-code 1 -level X -f ba} {-code 1 -level 0 -f ba} + 30 {-code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 31 {-code error -level X -f ba} {-code error -level 0 -f ba} + 32 {-code ok -level X -f ba} {-code 1 -level 0 -f ba} + 33 {-code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 34 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 35 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 36 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 37 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 38 {-code 1 -code error -level 0 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 39 {-code 1 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 40 {-code 1 -code error -level 5 -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 41 {-code 1 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 42 {-code 1 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 43 {-code 1 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 44 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} + 45 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 46 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} + 47 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 48 {-code 1 -code error -level 0 -f ba} {-code 1 -code error -level 0 -f ba} + 49 {-code 1 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 50 {-code 1 -code error -level 5 -f ba} {-code 1 -code error -level 0 -f ba} + 51 {-code 1 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 52 {-code 1 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 53 {-code 1 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 54 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 55 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 56 {-code 1 -code error -level X -f ba snarf} {-code 1 -code error -level 0 -f ba snarf} + 57 {-code 1 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 58 {-code 1 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 59 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} + 60 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 61 {-code 1 -code error -level X -f ba} {-code 1 -code error -level 0 -f ba} + 62 {-code 1 -code ok -level X -f ba} {-code 1 -level 0 -f ba} + 63 {-code 1 -code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 64 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 65 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 66 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 67 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 68 {-code 0 -code error -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 69 {-code 0 -code ok -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 70 {-code 0 -code error -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 71 {-code 0 -code ok -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 72 {-code 0 -code boss -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 73 {-code 0 -code boss -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 74 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + 75 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + 76 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + 77 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + 78 {-code 0 -code error -level 0 -f ba} {-code 1 -level 0 -f ba} + 79 {-code 0 -code ok -level 0 -f ba} {-code 1 -level 0 -f ba} + 80 {-code 0 -code error -level 5 -f ba} {-code 1 -level 0 -f ba} + 81 {-code 0 -code ok -level 5 -f ba} {-code 1 -level 0 -f ba} + 82 {-code 0 -code boss -level 0 -f ba} {-code 1 -level 0 -f ba} + 83 {-code 0 -code boss -level 5 -f ba} {-code 1 -level 0 -f ba} + 84 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 85 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 86 {-code 0 -code error -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 87 {-code 0 -code ok -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 88 {-code 0 -code boss -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + 89 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + 90 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + 91 {-code 0 -code error -level X -f ba} {-code 1 -level 0 -f ba} + 92 {-code 0 -code ok -level X -f ba} {-code 1 -level 0 -f ba} + 93 {-code 0 -code boss -level X -f ba} {-code 1 -level 0 -f ba} + + 94 {-code 1 -code 1 -level 0 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 95 {-code 0 -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 96 {-code 1 -code 1 -level 5 -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + 97 {-code 0 -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + 98 {-code error -code 1 -level 0 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + 99 {-code ok -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a0 {-code error -code 1 -level 5 -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + a1 {-code ok -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a2 {-code boss -code 1 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a3 {-code boss -code 1 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + a4 {-code 1 -code 1 -level 0 -f ba} {-code 1 -code 1 -level 0 -f ba} + a5 {-code 0 -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + a6 {-code 1 -code 1 -level 5 -f ba} {-code 1 -code 1 -level 0 -f ba} + a7 {-code 0 -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + a8 {-code error -code 1 -level 0 -f ba} {-code error -code 1 -level 0 -f ba} + a9 {-code ok -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + b0 {-code error -code 1 -level 5 -f ba} {-code error -code 1 -level 0 -f ba} + b1 {-code ok -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + b2 {-code boss -code 1 -level 0 -f ba} {-code 1 -level 0 -f ba} + b3 {-code boss -code 1 -level 5 -f ba} {-code 1 -level 0 -f ba} + b4 {-code 1 -code 1 -level X -f ba snarf} {-code 1 -code 1 -level 0 -f ba snarf} + b5 {-code 0 -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b6 {-code error -code 1 -level X -f ba snarf} {-code error -code 1 -level 0 -f ba snarf} + b7 {-code ok -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b8 {-code boss -code 1 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + b9 {-code 1 -code 1 -level X -f ba} {-code 1 -code 1 -level 0 -f ba} + c0 {-code 0 -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + c1 {-code error -code 1 -level X -f ba} {-code error -code 1 -level 0 -f ba} + c2 {-code ok -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + c3 {-code boss -code 1 -level X -f ba} {-code 1 -level 0 -f ba} + + c4 {-code 1 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c5 {-code 0 -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c6 {-code 1 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c7 {-code 0 -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c8 {-code error -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + c9 {-code ok -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d0 {-code error -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d1 {-code ok -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d2 {-code boss -code 0 -level 0 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d3 {-code boss -code 0 -level 5 -f ba snarf} {-code 1 -level 0 -f ba snarf} + d4 {-code 1 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d5 {-code 0 -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d6 {-code 1 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + d7 {-code 0 -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + d8 {-code error -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + d9 {-code ok -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + e0 {-code error -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e1 {-code ok -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e2 {-code boss -code 0 -level 0 -f ba} {-code 1 -level 0 -f ba} + e3 {-code boss -code 0 -level 5 -f ba} {-code 1 -level 0 -f ba} + e4 {-code 1 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e5 {-code 0 -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e6 {-code error -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e7 {-code ok -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e8 {-code boss -code 0 -level X -f ba snarf} {-code 1 -level 0 -f ba snarf} + e9 {-code 1 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f0 {-code 0 -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f1 {-code error -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f2 {-code ok -code 0 -level X -f ba} {-code 1 -level 0 -f ba} + f3 {-code boss -code 0 -level X -f ba} {-code 1 -level 0 -f ba} +} { + test io-71.$n {Tcl_SetChannelError} {testchannel} { + + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res [testchannel setchannelerror $c [lrange $msg 0 end]] + close $c + removeFile cutsplice + + set res + } [lrange $expected 0 end] + + test io-72.$n {Tcl_SetChannelErrorInterp} {testchannel} { + + set f [makeFile {... dummy ...} cutsplice] + set c [open $f r] + + set res [testchannel setchannelerrorinterp $c [lrange $msg 0 end]] + close $c + removeFile cutsplice + + set res + } [lrange $expected 0 end] +} + +# ### ### ### ######### ######### ######### + # cleanup foreach file [list fooBar longfile script output test1 pipe my_script foo \ bar test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] { diff --git a/tests/ioCmd.test b/tests/ioCmd.test index fd09bc7..2c95b13 100644 --- a/tests/ioCmd.test +++ b/tests/ioCmd.test @@ -1,3 +1,4 @@ +# -*- tcl -*- # Commands covered: open, close, gets, read, puts, seek, tell, eof, flush, # fblocked, fconfigure, open, channel, fcopy # @@ -12,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: ioCmd.test,v 1.23 2005/05/10 18:35:22 kennykb Exp $ +# RCS: @(#) $Id: ioCmd.test,v 1.24 2005/08/24 17:56:24 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -572,6 +573,3081 @@ test iocmd-15.12 {Tcl_FcopyObjCmd} {fcopy} { close $rfile close $wfile +# ### ### ### ######### ######### ######### +## Testing the reflected channel. + +test iocmd-20.0 {chan, wrong#args} { + catch {chan} msg + set msg +} {wrong # args: should be "chan subcommand ?argument ...?"} + +test iocmd-20.1 {chan, unknown method} { + catch {chan foo} msg + set msg +} {unknown or ambiguous subcommand "foo": must be blocked, close, configure, copy, create, eof, event, flush, gets, names, postevent, puts, read, seek, tell, or truncate} + +# --- --- --- --------- --------- --------- +# chan create, and method "initalize" + +test iocmd-21.0 {chan create, wrong#args, not enough} { + catch {chan create} msg + set msg +} {wrong # args: should be "chan create mode cmdprefix"} + +test iocmd-21.1 {chan create, wrong#args, too many} { + catch {chan create a b c} msg + set msg +} {wrong # args: should be "chan create mode cmdprefix"} + +test iocmd-21.2 {chan create, invalid r/w mode, empty} { + proc foo {} {} + catch {chan create {} foo} msg + rename foo {} + set msg +} {bad mode list: is empty} + +test iocmd-21.3 {chan create, invalid r/w mode, bad string} { + proc foo {} {} + catch {chan create {c} foo} msg + rename foo {} + set msg +} {bad mode "c": must be read or write} + +test iocmd-21.4 {chan create, bad handler, not a list} { + catch {chan create {r w} "foo \{"} msg + set msg +} {unmatched open brace in list} + +test iocmd-21.5 {chan create, bad handler, not a command} { + catch {chan create {r w} foo} msg + set msg +} {Initialize failure: invalid command name "foo"} + +test iocmd-21.6 {chan create, initialize failed, bad signature} { + proc foo {} {} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: wrong # args: should be "foo"} + +test iocmd-21.7 {chan create, initialize failed, bad signature} { + proc foo {} {} + catch {chan create {r w} ::foo} msg + rename foo {} + set msg +} {Initialize failure: wrong # args: should be "::foo"} + +test iocmd-21.8 {chan create, initialize failed, bad result, not a list} { + proc foo {args} {return "\{"} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: unmatched open brace in list} + +test iocmd-21.9 {chan create, initialize failed, bad result, not a list} { + proc foo {args} {return \{\{\}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: unmatched open brace in list} + +test iocmd-21.10 {chan create, initialize failed, bad result, empty list} { + proc foo {args} {} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Not all required methods supported} + +test iocmd-21.11 {chan create, initialize failed, bad result, bogus method name} { + proc foo {args} {return 1} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: bad method "1": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write} + +test iocmd-21.12 {chan create, initialize failed, bad result, ambiguous method name} { + proc foo {args} {return {a b c}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: ambiguous method "c": must be blocking, cget, cgetall, configure, finalize, initialize, read, seek, watch, or write} + +test iocmd-21.13 {chan create, initialize failed, bad result, required methods missing} { + proc foo {args} {return {initialize finalize}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Not all required methods supported} + +test iocmd-21.14 {chan create, initialize failed, bad result, mode/handler mismatch} { + proc foo {args} {return {initialize finalize watch read}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Writing not supported, but requested} + +test iocmd-21.15 {chan create, initialize failed, bad result, mode/handler mismatch} { + proc foo {args} {return {initialize finalize watch write}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: Reading not supported, but requested} + +test iocmd-21.16 {chan create, initialize failed, bad result, cget(all) mismatch} { + proc foo {args} {return {initialize finalize watch cget write read}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: 'cgetall' not supported, but should be, as 'cget' is} + +test iocmd-21.17 {chan create, initialize failed, bad result, cget(all) mismatch} { + proc foo {args} {return {initialize finalize watch cgetall read write}} + catch {chan create {r w} foo} msg + rename foo {} + set msg +} {Initialize failure: 'cget' not supported, but should be, as 'cgetall' is} + +test iocmd-21.18 {chan create, initialize ok, creates channel} -match glob -body { + proc foo {args} { + global res + lappend res $args + if {[lindex $args 0] ne "initialize"} {return} + return {initialize finalize watch read write} + } + set res {} + lappend res [file channel rc*] + lappend res [chan create {r w} foo] + lappend res [close [lindex $res end]] + lappend res [file channel rc*] + rename foo {} + set res +} -result {{} {initialize rc* {read write}} rc* {finalize rc*} {} {}} + +test iocmd-21.19 {chan create, init failure -> no channel, no finalize} -match glob -body { + proc foo {args} { + global res + lappend res $args + return {} + } + set res {} + lappend res [file channel rc*] + lappend res [catch {chan create {r w} foo} msg] + lappend res $msg + lappend res [file channel rc*] + rename foo {} + set res +} -result {{} {initialize rc* {read write}} 1 {Initialize failure: Not all required methods supported} {}} + +# --- --- --- --------- --------- --------- +# Helper commands to record the arguments to handler methods. + +proc note {item} {global res ; lappend res $item ; return} +proc track {} {upvar args item ; note $item; return} +proc notes {items} {foreach i $items {note $i}} + +# Helper command, canned result for 'initialize' method. +# Gets the optional methods as arguments. Use return features +# to post the result higher up. + +proc init {args} { + lappend args initialize finalize watch read write + return -code return $args +} + +proc oninit {args} { + upvar args hargs + if {[lindex $hargs 0] ne "initialize"} {return} + lappend args initialize finalize watch read write + return -code return $args +} + +proc onfinal {} { + upvar args hargs + if {[lindex $hargs 0] ne "finalize"} {return} + return -code return "" +} + +# --- --- --- --------- --------- --------- +# method finalize + +test iocmd-22.1 {chan finalize, handler destruction has no effect on channel} -match glob -body { + set res {} + proc foo {args} {track ; oninit; return} + note [set c [chan create {r w} foo]] + + rename foo {} + + note [file channels rc*] + note [catch {close $c} msg] ; note $msg + note [file channels rc*] + + set res +} -result {{initialize rc* {read write}} rc* rc* 1 {invalid command name "foo"} {}} + +test iocmd-22.2 {chan finalize, for close} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return {}} + note [set c [chan create {r w} foo]] + + close $c + + # Close deleted the channel. + note [file channels rc*] + + # Channel destruction does not kill handler command! + note [info command foo] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} + +test iocmd-22.3 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code error 5} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + # Channel is gone despite error. + note [file channels rc*] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} + +test iocmd-22.4 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; error FOO} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} + +test iocmd-22.5 {chan finalize, for close, arbitrary result, ignored} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return SOMETHING} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg]; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} + +test iocmd-22.6 {chan finalize, for close, break, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 3} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} + +test iocmd-22.7 {chan finalize, for close, continue, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 4} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} + +test iocmd-22.8 {chan finalize, for close, custom code, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 777 BANG} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg] ; note $msg + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} + +test iocmd-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG} + note [set c [chan create {r w} foo]] + + note [catch {close $c} msg opt] ; note $msg ; note $opt + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method read + +test iocmd-23.1 {chan read, regular data return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return snarf + } + set c [chan create {r w} foo] + + note [read $c 10] + close $c + + rename foo {} + set res +} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} + +test iocmd-23.2 {chan read, bad data return, to much} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return [string repeat snarf 1000] + } + set c [chan create {r w} foo] + + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 {read delivered more than requested}} + +test iocmd-23.3 {chan read, for non-readable channel} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + note MUST_NOT_HAPPEN + } + set c [chan create {w} foo] + + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {1 {channel "rc*" wasn't opened for reading}} + +test iocmd-23.4 {chan read, error return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.5 {chan read, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.6 {chan read, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.7 {chan read, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} + +test iocmd-23.8 {chan read, level is squashed} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -level 55 -code 777 BOOM! + } + set c [chan create {r w} foo] + note [catch {read $c 2} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} + +# --- === *** ########################### +# method write + +test iocmd-24.1 {chan write, regular write} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal ; track + set written [string length [lindex $args 2]] + note $written + return $written + } + set c [chan create {r w} foo] + + puts -nonewline $c snarf ; flush $c + close $c + + rename foo {} + set res +} -result {{write rc* snarf} 5} + +test iocmd-24.2 {chan write, partial write is ok} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + set written [string length [lindex $args 2]] + if {$written > 10} {set written [expr {$written / 2}]} + note $written + return $written + } + set c [chan create {r w} foo] + + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} + +test iocmd-24.3 {chan write, failed write} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1} + + set c [chan create {r w} foo] + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} -1} + +test iocmd-24.4 {chan write, non-writable channel} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {1 {channel "rc*" wasn't opened for writing}} + +test iocmd-24.5 {chan write, bad result, more written than data} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 10000} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd-24.6 {chan write, bad result, zero-length write} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 0} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd-24.7 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.8 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; error BOOM!} + set c [chan create {r w} foo] + + notes [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.9 {chan write, failed write, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.10 {chan write, failed write, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.11 {chan write, failed write, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} + +test iocmd-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return BANG} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} + +test iocmd-24.13 {chan write, failed write, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!} + set c [chan create {r w} foo] + + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt] + note $msg + note $opt + close $c + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} + +# --- === *** ########################### +# method cgetall + +test iocmd-25.1 {chan configure, cgetall, standard options} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c] + close $c + + rename foo {} + set res +} -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd-25.2 {chan configure, cgetall, no options} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""} + set c [chan create {r w} foo] + + note [fconfigure $c] + close $c + + rename foo {} + set res +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd-25.3 {chan configure, cgetall, regular result} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar foo -snarf x" + } + set c [chan create {r w} foo] + + note [fconfigure $c] + close $c + + rename foo {} + set res +} -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} + +test iocmd-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar" + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} + +test iocmd-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "\{" + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 {unmatched open brace in list}} + +test iocmd-25.6 {chan configure, cgetall, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.7 {chan configure, cgetall, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.8 {chan configure, cgetall, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.9 {chan configure, cgetall, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} + +test iocmd-25.10 {chan configure, cgetall, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 55 -code 777 BANG + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method configure + +test iocmd-26.1 {chan configure, set standard option} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN + return + } + set c [chan create {r w} foo] + + note [fconfigure $c -translation lf] + close $c + + rename foo {} + set res +} -result {{}} + +test iocmd-26.2 {chan configure, set option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.3 {chan configure, set option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit configure ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -rc-foo bar] + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} {}} + +test iocmd-26.4 {chan configure, set option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.5 {chan configure, set option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.6 {chan configure, set option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code 444 BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd-26.7 {chan configure, set option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -level 55 -code 444 BANG + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method cget + +test iocmd-27.1 {chan configure, get option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo} + set c [chan create {r w} foo] + + note [fconfigure $c -rc-foo] + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} foo} + +test iocmd-27.2 {chan configure, get option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.3 {chan configure, get option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.4 {chan configure, get option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.5 {chan configure, get option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 333 BOOM! + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd-27.6 {chan configure, get option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 77 -code 333 BANG + } + set c [chan create {r w} foo] + + note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +# --- === *** ########################### +# method seek + +test iocmd-28.1 {chan tell, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [tell $c] + close $c + + rename foo {} + set res +} -result {-1} + +test iocmd-28.2 {chan tell, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.3 {chan tell, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.4 {chan tell, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.5 {chan tell, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} + +test iocmd-28.6 {chan tell, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG} + set c [chan create {r w} foo] + + note [catch {tell $c} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +test iocmd-28.7 {chan tell, regular return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 88} + set c [chan create {r w} foo] + + note [tell $c] + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 88} + +test iocmd-28.8 {chan tell, negative return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -1} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} + +test iocmd-28.9 {chan tell, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + note [catch {tell $c} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} + +test iocmd-28.10 {chan seek, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {1 {error during seek on "rc*": invalid argument}} + +test iocmd-28.11 {chan seek, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.12 {chan seek, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.13 {chan seek, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.14 {chan seek, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} + +test iocmd-28.15 {chan seek, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +test iocmd-28.16 {chan seek, bogus return, negative location} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -45} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} + +test iocmd-28.17 {chan seek, bogus return, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + note [catch {seek $c 0 start} msg] ; note $msg + close $c + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} + +test iocmd-28.18 {chan seek, ok result} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 23} + set c [chan create {r w} foo] + + note [seek $c 0 current] + close $c + + rename foo {} + set res +} -result {{seek rc* 0 current} {}} + +foreach {n code} { + 0 start + 1 current + 2 end +} { + test iocmd-28.19.$n "chan seek, base conversion, $code" -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 0} + + set c [chan create {r w} foo] + note [seek $c 0 $code] + close $c + + rename foo {} + set res + } -result [list [list seek rc* 0 $code] {}] +} + +# --- === *** ########################### +# method blocking + +test iocmd-29.1 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {1} + +test iocmd-29.2 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {{} 0} + +test iocmd-29.3 {chan blocking, retrieval, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {1} + +test iocmd-29.4 {chan blocking, resetting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {{blocking rc* 0} {} 0} + +test iocmd-29.5 {chan blocking, setting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fconfigure $c -blocking 1] + note [fconfigure $c -blocking] + close $c + + rename foo {} + set res +} -result {{blocking rc* 1} {} 1} + +test iocmd-29.6 {chan blocking, error return} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!} + + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + # Catch the close. It changes blocking mode internally, and runs into the error result. + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.7 {chan blocking, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.8 {chan blocking, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.9 {chan blocking, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} + +test iocmd-29.10 {chan blocking, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} + +test iocmd-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + + catch {close $c} + rename foo {} + set res +} -result {{blocking rc* 0} 0 {}} + +# --- === *** ########################### +# method watch + +test iocmd-30.1 {chan watch, read interest, some return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return IGNORED} + set c [chan create {r w} foo] + + note [fileevent $c readable {set tick $tick}] + close $c ;# 2nd watch, interest zero. + + rename foo {} + set res +} -result {{watch rc* read} {} {watch rc* {}}} + +test iocmd-30.2 {chan watch, write interest, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED} + set c [chan create {r w} foo] + + note [fileevent $c writable {set tick $tick}] + note [fileevent $c writable {}] + close $c + + rename foo {} + set res +} -result {{watch rc* write} {} {watch rc* {}} {}} + +test iocmd-30.3 {chan watch, accumulated interests} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] + note [fileevent $c writable {}] + note [fileevent $c readable {}] + close $c + + rename foo {} + set res +} -result {{watch rc* write} {} {watch rc* {read write}} {} {watch rc* read} {} {watch rc* {}} {}} + +test iocmd-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] ;# Script is changing, + note [fileevent $c readable {set tock $tock}] ;# interest does not. + + close $c ;# 3rd and 4th watch, removing the event handlers. + rename foo {} + set res +} -result {{watch rc* write} {} {watch rc* {read write}} {} {} {watch rc* write} {watch rc* {}}} + +# --- === *** ########################### +# chan postevent + +test iocmd-31.1 {chan postevent, restricted to reflected channels} -match glob -body { + set c [open [makeFile {} goo] r] + + catch {chan postevent $c {r w}} msg + + close $c + removeFile goo + set msg +} -result {channel "file*" is not a reflected channel} + +test iocmd-31.2 {chan postevent, unwanted events} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c {r w}} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{tried to post events channel "rc*" is not interested in}} + +test iocmd-31.3 {chan postevent, bad input, empty list} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c {}} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{bad event list: is empty}} + +test iocmd-31.4 {chan postevent, bad input, illlegal keyword} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c goo} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{bad event "goo": must be read or write}} + +test iocmd-31.5 {chan postevent, bad input, not a list} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + catch {chan postevent $c "\{"} msg ; note $msg + close $c + + rename foo {} + set res +} -result {{unmatched open brace in list}} + +test iocmd-31.6 {chan postevent, posted events do happen} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c readable {note TOCK}] + + set stop [after 10000 {note TIMEOUT}] + after 1000 {note [chan postevent $c r]} + vwait ::res + catch {after cancel $stop} + close $c + + rename foo {} + set res +} -result {{watch rc* read} {} TOCK {} {watch rc* {}}} + +test iocmd-31.7 {chan postevent, posted events do happen} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + note [fileevent $c writable {note TOCK}] + + set stop [after 10000 {note TIMEOUT}] + after 1000 {note [chan postevent $c w]} + vwait ::res + catch {after cancel $stop} + close $c + + rename foo {} + set res +} -result {{watch rc* write} {} TOCK {} {watch rc* {}}} + +# ### ### ### ######### ######### ######### +## Same tests as above, but exercising the code forwarding and +## receiving driver operations to the originator thread. + +# -*- tcl -*- +# ### ### ### ######### ######### ######### +## Testing the reflected channel (Thread forwarding). +# +## The id numbers refer to the original test without thread +## forwarding, and gaps due to tests not applicable to forwarding are +## left to keep this asociation. + +testConstraint testchannel [llength [info commands testchannel]] + +# Duplicate of code in "thread.test". Find a better way of doing this +# without duplication. Maybe placement into a proc which transforms to +# nop after the first call, and placement of its defintion in a +# central location. + +testConstraint testthread [expr {[info commands testthread] != {}}] + +if {[testConstraint testthread]} { + testthread errorproc ThreadError + + proc ThreadError {id info} { + global threadError + set threadError $info + } + + proc ThreadNullError {id info} { + # ignore + } +} + +# ### ### ### ######### ######### ######### +## Helper command. Runs a script in a separate thread and returns the +## result. A channel is transfered into the thread as well, and list of +## configuation variables + +proc inthread {chan script args} { + + # Test thread. + + set tid [testthread create] + + # Init thread configuration. + # - Listed variables + # - Id of main thread + # - A number of helper commands + + foreach v $args { + upvar 1 $v x + testthread send $tid [list set $v $x] + } + testthread send $tid [list set mid $tcltest::mainThread] + testthread send $tid { + proc note {item} {global notes ; lappend notes $item} + proc notes {} {global notes ; return $notes} + } + testthread send $tid [list proc s {} [list uplevel 1 $script]] ; # (*) + + # Transfer channel (cut/splice aka detach/attach) + + testchannel cut $chan + testthread send $tid [list testchannel splice $chan] + + # Run test script, also run local event loop! + # The local event loop waits for the result to come back. + # It is also necessary for the execution of forwarded channel + # operations. + + set ::tres "" + testthread send -async $tid { + after 500 + catch {s} res ; # This runs the script, 's' was defined at (*) + testthread send -async $mid [list set ::tres $res] + } + vwait ::tres + # Remove test thread, and return the captured result. + + tcltest::threadReap + return $::tres +} + +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### + +test iocmd.tf-22.2 {chan finalize, for close} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return {}} + note [set c [chan create {r w} foo]] + + note [inthread $c { + close $c + # Close the deleted the channel. + file channels rc* + } c] + + # Channel destruction does not kill handler command! + note [info command foo] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo} + +test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code error 5} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + # Channel is gone despite error. + note [file channels rc*] + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}} + +test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; error FOO} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO} + +test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return SOMETHING} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg]; note $msg + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}} + +test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 3} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \ + -constraints {testchannel testthread} + +test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 4} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 {}} \ + -constraints {testchannel testthread} + +test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -code 777 BANG} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg] ; note $msg + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG} \ + -constraints {testchannel testthread} + +test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body { + set res {} + proc foo {args} {track ; oninit ; return -level 5 -code 777 BANG} + note [set c [chan create {r w} foo]] + + notes [inthread $c { + note [catch {close $c} msg opt] ; note $msg ; note $opt + notes + } c] + + rename foo {} + set res +} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method read + +test iocmd.tf-23.1 {chan read, regular data return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return snarf + } + set c [chan create {r w} foo] + notes [inthread $c { + note [read $c 10] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf} + +test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return [string repeat snarf 1000] + } + set c [chan create {r w} foo] + notes [inthread $c { + note [catch {[read $c 2]} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}} + +test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + note MUST_NOT_HAPPEN + } + set c [chan create {w} foo] + notes [inthread $c { + note [catch {[read $c 2]} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}} + +test iocmd.tf-23.4 {chan read, error return} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.5 {chan read, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + return -level 55 -code 777 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {read $c 2} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{read rc* 4096} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method write + +test iocmd.tf-24.1 {chan write, regular write} -match glob -body { + set res {} + proc foo {args} { + oninit; onfinal ; track + set written [string length [lindex $args 2]] + note $written + return $written + } + set c [chan create {r w} foo] + + inthread $c { + puts -nonewline $c snarf ; flush $c + close $c + } c + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarf} 5} + +test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body { + set res {} + proc foo {args} { + oninit ; onfinal ; track + set written [string length [lindex $args 2]] + if {$written > 10} {set written [expr {$written / 2}]} + note $written + return $written + } + set c [chan create {r w} foo] + + inthread $c { + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + } c + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8} + +test iocmd.tf-24.3 {chan write, failed write} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note -1 ; return -1} + set c [chan create {r w} foo] + + inthread $c { + puts -nonewline $c snarfsnarfsnarf ; flush $c + close $c + } c + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1} + +test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}} + +test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 10000} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd.tf-24.6 {chan write, zero writes} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return 0} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarf ; flush $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}} + +test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code 777 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg] + note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \ + -constraints {testchannel testthread} + +test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -level 55 -code 777 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {puts -nonewline $c snarfsnarfsnarf ; flush $c} msg opt] + note $msg + note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{write rc* snarfsnarfsnarf} 1 BOOM! {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BOOM!}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method cgetall + +test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return ""} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}} + +test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar foo -snarf x" + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}} + +test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "-bar" + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}} + +test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return "\{" + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}} + +test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!} + +test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 777 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 55 -code 777 BANG + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{cgetall rc*} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method configure + +test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track ; note MUST_NOT_HAPPEN + return + } + + set c [chan create {r w} foo] + notes [inthread $c { + note [fconfigure $c -translation lf] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{}} + +test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!} + +test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit configure ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -rc-foo bar] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}} + +test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code break BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -code 444 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit configure ; onfinal ; track + return -level 55 -code 444 BANG + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo bar} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{configure rc* -rc-foo bar} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method cget + +test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body { + set res {} + proc foo {args} {oninit cget cgetall ; onfinal ; track ; return foo} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -rc-foo] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo} + +test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!} + +test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code error BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code continue BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -code 333 BOOM! + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body { + set res {} + proc foo {args} { + oninit cget cgetall ; onfinal ; track + return -level 77 -code 333 BANG + } + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -rc-foo} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{cget rc* -rc-foo} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method seek + +test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [tell $c] + close $c + notes + } c] + + rename foo {} + set res +} -result {-1} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.2 {chan tell, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 222 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 11 -code 222 BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.7 {chan tell, regular return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 88} + set c [chan create {r w} foo] + + notes [inthread $c { + note [tell $c] + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 88} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.8 {chan tell, negative return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -1} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.9 {chan tell, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {tell $c} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {1 {error during seek on "rc*": invalid argument}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.11 {chan seek, error return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code error BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -code 99 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -level 33 -code 99 BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg opt] ; note $msg ; note $opt + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return -45} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {seek $c 0 start} msg] ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \ + -constraints {testchannel testthread} + +test iocmd.tf-28.18 {chan seek, ok result} -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 23} + set c [chan create {r w} foo] + + notes [inthread $c { + note [seek $c 0 current] + close $c + notes + } c] + + rename foo {} + set res +} -result {{seek rc* 0 current} {}} \ + -constraints {testchannel testthread} + +foreach {n code} { + 0 start + 1 current + 2 end +} { + test iocmd.tf-28.19.$n "chan seek, base conversion, $code" -match glob -body { + set res {} + proc foo {args} {oninit seek ; onfinal ; track ; return 0} + set c [chan create {r w} foo] + + notes [inthread $c { + note [seek $c 0 $code] + close $c + notes + } c code] + + rename foo {} + set res + } -result [list [list seek rc* 0 $code] {}] \ + -constraints {testchannel testthread} +} + +# --- === *** ########################### +# method blocking + +test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {1} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {{} 0} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; note MUST_NOT_HAPPEN ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {1} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking 0] + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} {} 0} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fconfigure $c -blocking 1] + note [fconfigure $c -blocking] + close $c + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 1} {} 1} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.6 {chan blocking, error return} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; error BOOM!} + + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + # Catch the close. It changes blocking mode internally, and runs into the error result. + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code break BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code continue BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -code 44 BOOM!} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BOOM!} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return -level 99 -code 44 BANG} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg opt] ; note $msg ; note $opt + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 1 BANG {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo BANG}} \ + -constraints {testchannel testthread} + +test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body { + set res {} + proc foo {args} {oninit blocking ; onfinal ; track ; return BOGUS} + set c [chan create {r w} foo] + + notes [inthread $c { + note [catch {fconfigure $c -blocking 0} msg] ; note $msg + catch {close $c} + notes + } c] + + rename foo {} + set res +} -result {{blocking rc* 0} 0 {}} \ + -constraints {testchannel testthread} + +# --- === *** ########################### +# method watch + +test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return IGNORED} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c readable {set tick $tick}] + close $c ;# 2nd watch, interest zero. + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}} + +test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return -code error BOOM!_IGNORED} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c writable {set tick $tick}] + note [fileevent $c writable {}] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}} + +test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] + note [fileevent $c writable {}] + note [fileevent $c readable {}] + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}} + +test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + note [fileevent $c writable {set tick $tick}] + note [fileevent $c readable {set tick $tick}] ;# Script is changing, + note [fileevent $c readable {set tock $tock}] ;# interest does not. + close $c ;# 3rd and 4th watch, removing the event handlers. + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}} + +# --- === *** ########################### +# postevent +# Not possible from a thread not containing the command handler. +# Check that this is rejected. + +test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body { + set res {} + proc foo {args} {oninit ; onfinal ; track ; return} + set c [chan create {r w} foo] + + notes [inthread $c { + catch {chan postevent $c r} msg ; note $msg + close $c + notes + } c] + + rename foo {} + set res +} -constraints {testchannel testthread} \ + -result {{postevent for channel "rc*" called from outside interpreter}} + + +# ### ### ### ######### ######### ######### + +# ### ### ### ######### ######### ######### + +rename track {} # cleanup foreach file [list test1 test2 test3 test4] { removeFile $file diff --git a/unix/Makefile.in b/unix/Makefile.in index 0875f19..a66fb08 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.172 2005/07/21 21:23:03 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.173 2005/08/24 17:56:24 andreas_kupries Exp $ VERSION = @TCL_VERSION@ MAJOR_VERSION = @TCL_MAJOR_VERSION@ @@ -302,7 +302,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \ tclCompile.o tclConfig.o tclDate.o tclDictObj.o tclEncoding.o \ tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ - tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ + tclIORChan.o tclIOGT.o tclIOSock.o tclIOUtil.o tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclPanic.o tclParse.o tclParseExpr.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ @@ -388,6 +388,7 @@ GENERIC_SRCS = \ $(GENERIC_DIR)/tclIOGT.c \ $(GENERIC_DIR)/tclIOSock.c \ $(GENERIC_DIR)/tclIOUtil.c \ + $(GENERIC_DIR)/tclIORChan.c \ $(GENERIC_DIR)/tclLink.c \ $(GENERIC_DIR)/tclListObj.c \ $(GENERIC_DIR)/tclLiteral.c \ @@ -1009,6 +1010,9 @@ tclIOSock.o: $(GENERIC_DIR)/tclIOSock.c tclIOUtil.o: $(GENERIC_DIR)/tclIOUtil.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIOUtil.c +tclIORChan.o: $(GENERIC_DIR)/tclIORChan.c + $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclIORChan.c + tclLink.o: $(GENERIC_DIR)/tclLink.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclLink.c diff --git a/win/Makefile.in b/win/Makefile.in index c2beb4b..7a0e7ce 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -5,7 +5,7 @@ # "autoconf" program (constructs like "@foo@" will get replaced in the # actual Makefile. # -# RCS: @(#) $Id: Makefile.in,v 1.90 2005/08/11 22:06:47 kennykb Exp $ +# RCS: @(#) $Id: Makefile.in,v 1.91 2005/08/24 17:56:24 andreas_kupries Exp $ VERSION = @TCL_VERSION@ @@ -242,6 +242,7 @@ GENERIC_OBJS = \ tclIO.$(OBJEXT) \ tclIOCmd.$(OBJEXT) \ tclIOGT.$(OBJEXT) \ + tclIORChan.$(OBJEXT) \ tclIOSock.$(OBJEXT) \ tclIOUtil.$(OBJEXT) \ tclLink.$(OBJEXT) \ diff --git a/win/makefile.vc b/win/makefile.vc index 84a6867..3ced0df 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -12,7 +12,7 @@ # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.138 2005/08/05 18:15:27 kennykb Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.139 2005/08/24 17:56:24 andreas_kupries Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -284,6 +284,7 @@ TCLOBJS = \ $(TMP_DIR)\tclIOGT.obj \ $(TMP_DIR)\tclIOSock.obj \ $(TMP_DIR)\tclIOUtil.obj \ + $(TMP_DIR)\tclIORChan.obj \ $(TMP_DIR)\tclLink.obj \ $(TMP_DIR)\tclListObj.obj \ $(TMP_DIR)\tclLiteral.obj \ |