Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,7 +1,13 @@ 2000-08-14 Jeff Hobbs + * tlsInt.h: + * tlsIO.c: + * tlsBIO.c: + * tls.c: changed around to only working with 8.2.0+ (8.3.2+ + preferred), with runtime checks for pre- and post-io-rewrite. + * tls.c (Tls_Init): changed it to require 8.3.2 when Tcl_InitStubs was called because we don't want people using TLS with the original stacked channel implementation. 2000-07-26 Jeff Hobbs Index: tls.c ================================================================== --- tls.c +++ tls.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-1999 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.8 2000/08/14 21:55:12 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.9 2000/08/15 00:02:08 hobbs Exp $ * * TLS (aka SSL) Channel - can be layered on any bi-directional * Tcl_Channel (Note: Requires Trf Core Patch) * * This was built (almost) from scratch based upon observation of @@ -86,10 +86,15 @@ return(NULL); return(dh); } #endif +/* + * Defined in Tls_Init to determine what kind of channels we are using + * (old-style 8.2.0-8.3.1 or new-style 8.3.2+). + */ +int channelTypeVersion; /* * We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2 * libraries instead of the current OpenSSL libraries. */ @@ -540,16 +545,16 @@ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } -#ifdef TCL_CHANNEL_VERSION_2 - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + } if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; } @@ -640,16 +645,16 @@ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } -#ifdef TCL_CHANNEL_VERSION_2 - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + } for (idx = 2; idx < objc; idx++) { char *opt = Tcl_GetStringFromObj(objv[idx], NULL); if (opt[0] != '-') @@ -694,16 +699,16 @@ /* Get the "model" context */ chan = Tcl_GetChannel(interp, model, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } -#ifdef TCL_CHANNEL_VERSION_2 - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + } if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; } @@ -741,29 +746,22 @@ * encryption not to get goofed up). * We only want to adjust the buffering in pre-v2 channels, where * each channel in the stack maintained its own buffers. */ Tcl_SetChannelOption(interp, chan, "-translation", "binary"); -#ifndef TCL_CHANNEL_VERSION_2 - Tcl_SetChannelOption(interp, chan, "-buffering", "none"); -#endif - -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2 - statePtr->parent = chan; - statePtr->self = Tcl_ReplaceChannel(interp, - Tls_ChannelType(), (ClientData) statePtr, - (TCL_READABLE | TCL_WRITABLE), statePtr->parent); -#else -#ifdef TCL_CHANNEL_VERSION_2 - statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), - (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); -#else - statePtr->self = chan; - Tcl_StackChannel( interp, Tls_ChannelType(), (ClientData) statePtr, - (TCL_READABLE | TCL_WRITABLE), chan); -#endif -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { + Tcl_SetChannelOption(interp, chan, "-buffering", "none"); + } + + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); + } else { + statePtr->self = chan; + Tcl_StackChannel(interp, Tls_ChannelType(), + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); + } if (statePtr->self == (Tcl_Channel) NULL) { /* * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. */ Tls_Free((char *) statePtr); @@ -1022,16 +1020,16 @@ chan = Tcl_GetChannel(interp, channelName, &mode); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } -#ifdef TCL_CHANNEL_VERSION_2 - /* - * Make sure to operate on the topmost channel - */ - chan = Tcl_GetTopChannel(chan); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + } if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; } @@ -1138,21 +1136,42 @@ int Tls_Init(Tcl_Interp *interp) /* Interpreter in which the package is * to be made available. */ { -#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 2 + int major, minor, release, serial; + /* * The original 8.2.0 stacked channel implementation (and the patch * that preceded it) had problems with scalability and robustness. * These were address in 8.3.2 / 8.4a2, so we now require that as a - * minimum for TLS 1.4+. + * minimum for TLS 1.4+. We only support 8.2+ now (8.3.2+ preferred). */ - if (Tcl_InitStubs(interp, "8.3.2", 0) == NULL) { + if ( +#ifdef USE_TCL_STUBS + Tcl_InitStubs(interp, "8.2", 0) +#else + Tcl_PkgRequire(interp, "Tcl", "8.2", 0) +#endif + == NULL) { return TCL_ERROR; } -#endif + + /* + * Get the version so we can runtime switch on available functionality. + * TLS should really only be used in 8.3.2+, but the other works for + * some limited functionality, so an attempt at support is made. + */ + Tcl_GetVersion(&major, &minor, &release, &serial); + if ((major > 8) || ((major == 8) && ((minor > 3) || ((minor == 3) && + (release == TCL_FINAL_RELEASE) && (serial >= 2))))) { + /* 8.3.2+ */ + channelTypeVersion = TLS_CHANNEL_VERSION_2; + } else { + /* 8.2.0 - 8.3.1 */ + channelTypeVersion = TLS_CHANNEL_VERSION_1; + } if (SSL_library_init() != 1) { Tcl_AppendResult(interp, "could not initialize SSL library", NULL); return TCL_ERROR; } Index: tlsBIO.c ================================================================== --- tlsBIO.c +++ tlsBIO.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.3 2000/07/27 01:58:18 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.4 2000/08/15 00:02:08 hobbs Exp $ * * Provides BIO layer to interface openssl to Tcl. */ #include "tlsInt.h" @@ -61,15 +61,15 @@ Tcl_Channel chan = Tls_GetParent((State*)(bio->ptr)); int ret; dprintf(stderr,"\nBioWrite(0x%x, , %d) [0x%x]", bio, bufLen, chan); -#ifdef TCL_CHANNEL_VERSION_2 - ret = Tcl_WriteRaw(chan, buf, bufLen); -#else - ret = Tcl_Write(chan, buf, bufLen); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + ret = Tcl_WriteRaw(chan, buf, bufLen); + } else { + ret = Tcl_Write(chan, buf, bufLen); + } dprintf(stderr,"\n[0x%x] BioWrite(%d) -> %d [%d.%d]", chan, bufLen, ret, Tcl_Eof(chan), Tcl_GetErrno()); BIO_clear_flags(bio, BIO_FLAGS_WRITE|BIO_FLAGS_SHOULD_RETRY); @@ -97,15 +97,15 @@ dprintf(stderr,"\nBioRead(0x%x, , %d) [0x%x]", bio, bufLen, chan); if (buf == NULL) return 0; -#ifdef TCL_CHANNEL_VERSION_2 - ret = Tcl_ReadRaw(chan, buf, bufLen); -#else - ret = Tcl_Read(chan, buf, bufLen); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + ret = Tcl_ReadRaw(chan, buf, bufLen); + } else { + ret = Tcl_Read(chan, buf, bufLen); + } dprintf(stderr,"\n[0x%x] BioRead(%d) -> %d [%d.%d]", chan, bufLen, ret, Tcl_Eof(chan), Tcl_GetErrno()); BIO_clear_flags(bio, BIO_FLAGS_READ|BIO_FLAGS_SHOULD_RETRY); @@ -190,20 +190,14 @@ break; case BIO_CTRL_DUP: break; case BIO_CTRL_FLUSH: dprintf(stderr, "BIO_CTRL_FLUSH\n"); - if ( -#ifdef TCL_CHANNEL_VERSION_2 - Tcl_WriteRaw(chan, "", 0) >= 0 -#else - Tcl_Flush(chan) == TCL_OK -#endif - ) { - ret = 1; + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1); } else { - ret = -1; + ret = ((Tcl_Flush(chan) == TCL_OK) ? 1 : -1); } break; default: ret = 0; break; Index: tlsIO.c ================================================================== --- tlsIO.c +++ tlsIO.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.8 2000/07/27 01:58:18 hobbs Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.9 2000/08/15 00:02:08 hobbs Exp $ * * TLS (aka SSL) Channel - can be layered on any bi-directional * Tcl_Channel (Note: Requires Trf Core Patch) * * This was built from scratch based upon observation of OpenSSL 0.9.2B @@ -54,14 +54,19 @@ /* * This structure describes the channel type structure for TCP socket * based IO: */ -#ifdef TCL_CHANNEL_VERSION_2 -static Tcl_ChannelType tlsChannelType = { +static Tcl_ChannelType tlsChannelType2 = { "tls", /* Type name. */ - TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2/8.4a2+) */ +#ifndef TCL_CHANNEL_VERSION_2 + /* + * Avoids warning in Windows compiler when compiling with 8.3.1-. + */ + (Tcl_DriverBlockModeProc *) +#endif + TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2+) */ TlsCloseProc, /* Close proc. */ TlsInputProc, /* Input proc. */ TlsOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ @@ -71,13 +76,19 @@ NULL, /* Close2Proc. */ TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ NULL, /* FlushProc. */ TlsNotifyProc, /* handlerProc. */ }; -#else -static Tcl_ChannelType tlsChannelType = { + +static Tcl_ChannelType tlsChannelType1 = { "tls", /* Type name. */ +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Avoids warning in Windows compiler when compiling with 8.3.2+. + */ + (Tcl_ChannelTypeVersion) +#endif TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ TlsCloseProc, /* Close proc. */ TlsInputProc, /* Input proc. */ TlsOutputProc, /* Output proc. */ NULL, /* Seek proc. */ @@ -84,15 +95,18 @@ NULL, /* Set option proc. */ TlsGetOptionProc, /* Get option proc. */ TlsWatchProc, /* Initialize notifier. */ TlsGetHandleProc, /* Get file handle out of channel. */ }; -#endif Tcl_ChannelType *Tls_ChannelType() { - return &tlsChannelType; + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + return &tlsChannelType2; + } else { + return &tlsChannelType1; + } } /* *------------------------------------------------------------------- * @@ -120,16 +134,16 @@ if (mode == TCL_MODE_NONBLOCKING) { statePtr->flags |= TLS_TCL_ASYNC; } else { statePtr->flags &= ~(TLS_TCL_ASYNC); } -#ifdef TCL_CHANNEL_VERSION_2 - return 0; -#else - return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr), + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + return 0; + } else { + return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr), "-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1"); -#endif + } } /* *------------------------------------------------------------------- * @@ -155,19 +169,19 @@ { State *statePtr = (State *) instanceData; dprintf(stderr,"\nTlsCloseProc(0x%x)", statePtr); -#ifndef TCL_CHANNEL_VERSION_2 - /* - * Remove event handler to underlying channel, this could - * be because we are closing for real, or being "unstacked". - */ - - Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - TlsChannelHandler, (ClientData) statePtr); -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_1) { + /* + * Remove event handler to underlying channel, this could + * be because we are closing for real, or being "unstacked". + */ + + Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), + TlsChannelHandler, (ClientData) statePtr); + } Tls_Clean(statePtr); Tcl_EventuallyFree((ClientData)statePtr, Tls_Free); return TCL_OK; } @@ -361,12 +375,10 @@ * TlsGetOptionProc -- * * Computes an option value for a SSL socket based channel, or a * list of all options and their values. * - * Note: This code is based on code contributed by John Haxby. - * * Results: * A standard Tcl result. The value of the specified option or a * list of all options and their values is returned in the * supplied DString. * @@ -375,59 +387,58 @@ * *------------------------------------------------------------------- */ static int TlsGetOptionProc(ClientData instanceData, /* Socket state. */ - Tcl_Interp *interp, /* For errors - can be NULL. */ - char *optionName, /* Name of the option to - * retrieve the value for, or - * NULL to get all options and - * their values. */ - Tcl_DString *dsPtr) /* Where to store the computed value - * initialized by caller. */ -{ -#ifdef TCL_CHANNEL_VERSION_2 - State *statePtr = (State *) instanceData; - Tcl_Channel downChan = Tls_GetParent(statePtr); - Tcl_DriverGetOptionProc *getOptionProc; - - getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); - if (getOptionProc != NULL) { - return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), - interp, optionName, dsPtr); - } else if (optionName == (char*) NULL) { - /* - * Request is query for all options, this is ok. - */ - return TCL_OK; - } - /* - * Request for a specific option has to fail, we don't have any. - */ - return TCL_ERROR; -#else - State *statePtr = (State *) instanceData; - size_t len = 0; - - if (optionName != (char *) NULL) { - len = strlen(optionName); - } -#if 0 - if ((len == 0) || - ((len > 1) && (optionName[1] == 'c') && - (strncmp(optionName, "-cipher", len) == 0))) { - if (len == 0) { - Tcl_DStringAppendElement(dsPtr, "-cipher"); - } - Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl)); - if (len) { - return TCL_OK; - } - } -#endif - return TCL_OK; -#endif + Tcl_Interp *interp, /* For errors - can be NULL. */ + char *optionName, /* Name of the option to + * retrieve the value for, or + * NULL to get all options and + * their values. */ + Tcl_DString *dsPtr) /* Where to store the computed value + * initialized by caller. */ +{ + State *statePtr = (State *) instanceData; + + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + Tcl_Channel downChan = Tls_GetParent(statePtr); + Tcl_DriverGetOptionProc *getOptionProc; + + getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); + if (getOptionProc != NULL) { + return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), + interp, optionName, dsPtr); + } else if (optionName == (char*) NULL) { + /* + * Request is query for all options, this is ok. + */ + return TCL_OK; + } + /* + * Request for a specific option has to fail, we don't have any. + */ + return TCL_ERROR; + } else { + size_t len = 0; + + if (optionName != (char *) NULL) { + len = strlen(optionName); + } +#if 0 + if ((len == 0) || ((len > 1) && (optionName[1] == 'c') && + (strncmp(optionName, "-cipher", len) == 0))) { + if (len == 0) { + Tcl_DStringAppendElement(dsPtr, "-cipher"); + } + Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl)); + if (len) { + return TCL_OK; + } + } +#endif + return TCL_OK; + } } /* *------------------------------------------------------------------- * @@ -451,67 +462,68 @@ * combination of TCL_READABLE, * TCL_WRITABLE and TCL_EXCEPTION. */ { State *statePtr = (State *) instanceData; -#ifdef TCL_CHANNEL_VERSION_2 - Tcl_Channel downChan; - - statePtr->watchMask = mask; - - /* No channel handlers any more. We will be notified automatically - * about events on the channel below via a call to our - * 'TransformNotifyProc'. But we have to pass the interest down now. - * We are allowed to add additional 'interest' to the mask if we want - * to. But this transformation has no such interest. It just passes - * the request down, unchanged. - */ - - downChan = Tls_GetParent(statePtr); - - (Tcl_GetChannelType(downChan)) - ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); - - /* - * Management of the internal timer. - */ - - if (statePtr->timer != (Tcl_TimerToken) NULL) { - Tcl_DeleteTimerHandler(statePtr->timer); - statePtr->timer = (Tcl_TimerToken) NULL; - } - if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { - /* - * There is interest in readable events and we actually have - * data waiting, so generate a timer to flush that. - */ - statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, - TlsChannelHandlerTimer, (ClientData) statePtr); - } -#else - if (mask == statePtr->watchMask) - return; - - if (statePtr->watchMask) { - /* - * Remove event handler to underlying channel, this could - * be because we are closing for real, or being "unstacked". - */ - - Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - TlsChannelHandler, (ClientData) statePtr); - } - statePtr->watchMask = mask; - if (statePtr->watchMask) { - /* - * Setup active monitor for events on underlying Channel. - */ - - Tcl_CreateChannelHandler(Tls_GetParent(statePtr), - statePtr->watchMask, TlsChannelHandler, (ClientData) statePtr); - } -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + Tcl_Channel downChan; + + statePtr->watchMask = mask; + + /* No channel handlers any more. We will be notified automatically + * about events on the channel below via a call to our + * 'TransformNotifyProc'. But we have to pass the interest down now. + * We are allowed to add additional 'interest' to the mask if we want + * to. But this transformation has no such interest. It just passes + * the request down, unchanged. + */ + + downChan = Tls_GetParent(statePtr); + + (Tcl_GetChannelType(downChan)) + ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); + + /* + * Management of the internal timer. + */ + + if (statePtr->timer != (Tcl_TimerToken) NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + } + if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { + /* + * There is interest in readable events and we actually have + * data waiting, so generate a timer to flush that. + */ + statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, + TlsChannelHandlerTimer, (ClientData) statePtr); + } + } else { + if (mask == statePtr->watchMask) + return; + + if (statePtr->watchMask) { + /* + * Remove event handler to underlying channel, this could + * be because we are closing for real, or being "unstacked". + */ + + Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), + TlsChannelHandler, (ClientData) statePtr); + } + statePtr->watchMask = mask; + if (statePtr->watchMask) { + /* + * Setup active monitor for events on underlying Channel. + */ + + Tcl_CreateChannelHandler(Tls_GetParent(statePtr), + statePtr->watchMask, TlsChannelHandler, + (ClientData) statePtr); + } + } } /* *------------------------------------------------------------------- * @@ -582,11 +594,10 @@ } return mask; } -#ifndef TCL_CHANNEL_VERSION_2 /* *------------------------------------------------------* * * TlsChannelHandler -- * @@ -662,11 +673,10 @@ statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, TlsChannelHandlerTimer, (ClientData) statePtr); } Tcl_Release( (ClientData)statePtr); } -#endif /* *------------------------------------------------------* * * TlsChannelHandlerTimer -- @@ -778,52 +788,48 @@ Tcl_Channel Tls_GetParent( statePtr ) State *statePtr; { -#ifdef TCL_CHANNEL_VERSION_2 - return Tcl_GetStackedChannel(statePtr->self); -#else -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2 - return statePtr->parent; -#else - /* The reason for the existence of this procedure is - * the fact that stacking a transform over another - * transform will leave our internal pointer unchanged, - * and thus pointing to the new transform, and not the - * Channel structure containing the saved state of this - * transform. This is the price to pay for leaving - * Tcl_Channel references intact. The only other solution - * is an extension of Tcl_ChannelType with another driver - * procedure to notify a Channel about the (un)stacking. - * - * It walks the chain of Channel structures until it - * finds the one pointing having 'ctrl' as instanceData - * and then returns the superceding channel to that. (AK) - */ - - Tcl_Channel self = statePtr->self; - Tcl_Channel next; - - while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { - next = Tcl_GetStackedChannel (self); - if (next == (Tcl_Channel) NULL) { - /* 09/24/1999 Unstacking bug, - * found by Matt Newman . - * - * We were unable to find the channel structure for this - * transformation in the chain of stacked channel. This - * means that we are currently in the process of unstacking - * it *and* there were some bytes waiting which are now - * flushed. In this situation the pointer to the channel - * itself already refers to the parent channel we have to - * write the bytes into, so we return that. - */ - return statePtr->self; - } - self = next; - } - - return Tcl_GetStackedChannel (self); -#endif -#endif + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + return Tcl_GetStackedChannel(statePtr->self); + } else { + /* The reason for the existence of this procedure is + * the fact that stacking a transform over another + * transform will leave our internal pointer unchanged, + * and thus pointing to the new transform, and not the + * Channel structure containing the saved state of this + * transform. This is the price to pay for leaving + * Tcl_Channel references intact. The only other solution + * is an extension of Tcl_ChannelType with another driver + * procedure to notify a Channel about the (un)stacking. + * + * It walks the chain of Channel structures until it + * finds the one pointing having 'ctrl' as instanceData + * and then returns the superceding channel to that. (AK) + */ + + Tcl_Channel self = statePtr->self; + Tcl_Channel next; + + while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { + next = Tcl_GetStackedChannel (self); + if (next == (Tcl_Channel) NULL) { + /* 09/24/1999 Unstacking bug, + * found by Matt Newman . + * + * We were unable to find the channel structure for this + * transformation in the chain of stacked channel. This + * means that we are currently in the process of unstacking + * it *and* there were some bytes waiting which are now + * flushed. In this situation the pointer to the channel + * itself already refers to the parent channel we have to + * write the bytes into, so we return that. + */ + return statePtr->self; + } + self = next; + } + + return Tcl_GetStackedChannel (self); + } } Index: tlsInt.h ================================================================== --- tlsInt.h +++ tlsInt.h @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsInt.h,v 1.5 2000/06/06 01:34:12 welch Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsInt.h,v 1.6 2000/08/15 00:02:08 hobbs Exp $ * * TLS (aka SSL) Channel - can be layered on any bi-directional * Tcl_Channel (Note: Requires Trf Core Patch) * * This was built from scratch based upon observation of OpenSSL 0.9.2B @@ -83,13 +83,10 @@ * * The SSL processing context is maintained here, in the ClientData */ typedef struct State { Tcl_Channel self; /* this socket channel */ -#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2 - Tcl_Channel parent; /* underlying channel */ -#endif Tcl_TimerToken timer; int flags; /* currently only CHANNEL_ASYNC */ int watchMask; /* current WatchProc mask */ int mode; /* current mode of parent channel */ @@ -104,10 +101,116 @@ BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */ char *err; } State; +/* + * The following definitions have to be usable for 8.0.x, 8.1.x, 8.2.x, + * 8.3.[01], 8.3.2 and beyond. The differences between these versions: + * + * 8.0-8.1: There is no support for these in TLS 1.4 (get 1.3). This + * was the version with the original patch. + * + * 8.2.0- Changed semantics for Tcl_StackChannel (Tcl_ReplaceChannel). + * 8.3.1: Check at runtime to switch the behaviour. The patch is part + * of the core from now on. + * + * 8.3.2+: Stacked channels rewritten for better behaviour in some + * situations (closing). Some new API's, semantic changes. + * + * The following magic was taken from Trf 2.1 (Kupries). + */ + +#define TLS_CHANNEL_VERSION_1 0x1 +#define TLS_CHANNEL_VERSION_2 0x2 +extern int channelTypeVersion; + +#ifdef USE_TCL_STUBS +#ifndef Tcl_StackChannel +/* + * The core we are compiling against is not patched, so supply the + * necesssary definitions here by ourselves. The form chosen for + * the procedure macros (reservedXXX) will notify us if the core + * does not have these reserved locations anymore. + * + * !! Synchronize the procedure indices in their definitions with + * the patch to tcl.decls, as they have to be the same. + */ + +/* 281 */ +typedef Tcl_Channel (tls_StackChannel) _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_ChannelType* typePtr, + ClientData instanceData, + int mask, + Tcl_Channel prevChan)); +/* 282 */ +typedef void (tls_UnstackChannel) _ANSI_ARGS_((Tcl_Interp* interp, + Tcl_Channel chan)); + +#define Tcl_StackChannel ((tls_StackChannel*) tclStubsPtr->reserved281) +#define Tcl_UnstackChannel ((tls_UnstackChannel*) tclStubsPtr->reserved282) + +#endif /* Tcl_StackChannel */ + +#ifndef Tcl_GetStackedChannel +/* + * Separate definition, available in 8.2, but not 8.1 and before ! + */ + +/* 283 */ +typedef Tcl_Channel (tls_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan)); + +#define Tcl_GetStackedChannel ((tls_GetStackedChannel*) tclStubsPtr->reserved283) + +#endif /* Tcl_GetStackedChannel */ + + +#ifndef Tcl_WriteRaw +/* + * Core is older than 8.3.2. Supply the missing definitions for + * the new API's in 8.3.2. + */ + +/* 394 */ +typedef int (tls_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char *dst, + int bytesToRead)); +/* 395 */ +typedef int (tls_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, char *src, + int srcLen)); +/* 397 */ +typedef int (tls_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan)); + +/* + * Generating code for accessing these parts of the stub table when + * compiling against a core older than 8.3.2 is a hassle because even + * the 'reservedXXX' fields of the structure are not defined yet. So + * we have to write up some macros hiding some very hackish pointer + * arithmetics to get at these fields. We assume that pointer to + * functions are always of the same size. + */ + +#define STUB_BASE ((char*)(&(tclStubsPtr->tcl_UtfNcasecmp))) /* field 370 */ +#define procPtrSize (sizeof (Tcl_DriverBlockModeProc *)) +#define IDX(n) (((n)-370) * procPtrSize) +#define SLOT(n) (STUB_BASE + IDX(n)) + +#define Tcl_ReadRaw (*((tls_ReadRaw**) (SLOT(394)))) +#define Tcl_WriteRaw (*((tls_WriteRaw**) (SLOT(395)))) +#define Tcl_GetTopChannel (*((tls_GetTopChannel**)(SLOT(396)))) + +typedef struct TlsChannelTypeVersion_* TlsChannelTypeVersion; +#define TCL_CHANNEL_VERSION_2 ((TlsChannelTypeVersion) 0x2) + +/* + * Required, easy emulation. + */ +#define Tcl_ChannelGetOptionProc(chanDriver) ((chanDriver)->getOptionProc) + +#endif /* Tcl_WriteRaw */ + +#endif /* USE_TCL_STUBS */ + /* * Forward declarations */ EXTERN Tcl_ChannelType *Tls_ChannelType _ANSI_ARGS_((void));