Merge commit '15cf84c34642af290d1fdf16011f9290c941fa13' as 'tls'

1 files changed, 1005 insertions, 0 deletions

diff --git a/tls/tlsIO.c b/tls/tlsIO.c
new file mode 100644
index 0000000..9b22548
--- /dev/null
+++ b/tls/tlsIO.c
@@ -0,0 +1,1005 @@
+/*
+ * Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
+ * Copyright (C) 2000 Ajuba Solutions
+ *
+ * $Header: /cvsroot/tls/tls/tlsIO.c,v 1.19 2015/06/06 09:07:08 apnadkarni 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
+ *
+ * Addition credit is due for Andreas Kupries (a.kupries@westend.com), for
+ * providing the Tcl_ReplaceChannel mechanism and working closely with me
+ * to enhance it to support full fileevent semantics.
+ *
+ * Also work done by the follow people provided the impetus to do this "right":
+ *	tclSSL (Colin McCormack, Shared Technology)
+ *	SSLtcl (Peter Antman)
+ *
+ */
+
+#include "tlsInt.h"
+
+/*
+ * Forward declarations
+ */
+
+static int	TlsBlockModeProc _ANSI_ARGS_((ClientData instanceData,
+			int mode));
+static int	TlsCloseProc _ANSI_ARGS_ ((ClientData instanceData,
+			Tcl_Interp *interp));
+static int	TlsInputProc _ANSI_ARGS_((ClientData instanceData,
+			char *buf, int bufSize, int *errorCodePtr));
+static int	TlsOutputProc _ANSI_ARGS_((ClientData instanceData,
+			CONST char *buf, int toWrite, int *errorCodePtr));
+static int	TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData,
+			Tcl_Interp *interp, CONST84 char *optionName,
+			Tcl_DString *dsPtr));
+static void	TlsWatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
+static int	TlsGetHandleProc _ANSI_ARGS_ ((ClientData instanceData,
+			int direction, ClientData *handlePtr));
+static int	TlsNotifyProc _ANSI_ARGS_ ((ClientData instanceData,
+			int mask));
+static void	TlsChannelHandler _ANSI_ARGS_ ((ClientData clientData,
+			int mask));
+static void	TlsChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData));
+
+/*
+ * This structure describes the channel type structure for TCP socket
+ * based IO.  These are what the structures should look like, but we
+ * have to build them up at runtime to be correct depending on whether
+ * we are loaded into an 8.2.0-8.3.1 or 8.3.2+ Tcl interpreter.
+ */
+#ifdef TLS_STATIC_STRUCTURES_NOT_USED
+static Tcl_ChannelType tlsChannelType2 = {
+    "tls",		/* Type name. */
+    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. */
+    TlsGetOptionProc,	/* Get option proc. */
+    TlsWatchProc,	/* Initialize notifier. */
+    TlsGetHandleProc,	/* Get file handle out of channel. */
+    NULL,		/* Close2Proc. */
+    TlsBlockModeProc,	/* Set blocking/nonblocking mode.*/
+    NULL,		/* FlushProc. */
+    TlsNotifyProc,	/* handlerProc. */
+};
+
+static Tcl_ChannelType tlsChannelType1 = {
+    "tls",		/* Type name. */
+    TlsBlockModeProc,	/* Set blocking/nonblocking mode.*/
+    TlsCloseProc,	/* Close proc. */
+    TlsInputProc,	/* Input proc. */
+    TlsOutputProc,	/* Output proc. */
+    NULL,		/* Seek proc. */
+    NULL,		/* Set option proc. */
+    TlsGetOptionProc,	/* Get option proc. */
+    TlsWatchProc,	/* Initialize notifier. */
+    TlsGetHandleProc,	/* Get file handle out of channel. */
+};
+#else
+static Tcl_ChannelType *tlsChannelType = NULL;
+#endif
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_ChannelType --
+ *
+ *	Return the correct TLS channel driver info
+ *
+ * Results:
+ *	The correct channel driver for the current version of Tcl.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------
+ */
+Tcl_ChannelType *Tls_ChannelType()
+{
+    /*
+     * Initialize the channel type if necessary
+     */
+    if (tlsChannelType == NULL) {
+	/*
+	 * Allocation of a new channeltype structure is not easy, because of
+	 * the various verson of the core and subsequent changes to the
+	 * structure. The main challenge is to allocate enough memory for
+	 * odern versions even if this extyension is compiled against one
+	 * of the older variant!
+	 *
+	 * (1) Versions before stubs (8.0.x) are simple, because they are
+	 *     supported only if the extension is compiled against exactly
+	 *     that version of the core.
+	 *
+	 * (2) With stubs we just determine the difference between the older
+	 *     and modern variant and overallocate accordingly if compiled
+	 *     against an older variant.
+	 */
+
+	unsigned int size = sizeof(Tcl_ChannelType); /* Base size */
+
+	/*
+	 * Size of a procedure pointer. We assume that all procedure
+	 * pointers are of the same size, regardless of exact type
+	 * (arguments and return values).
+	 *
+	 * 8.2.   First version containing close2proc. Baseline.
+	 * 8.3.2  Three additional vectors. Moved blockMode, new flush- and
+	 *        handlerProc's.
+	 *
+	 * => Compilation against earlier version has to overallocate three
+	 *    procedure pointers.
+	 */
+
+#ifdef EMULATE_CHANNEL_VERSION_2
+	size += 3 * procPtrSize;
+#endif
+
+	tlsChannelType = (Tcl_ChannelType *) ckalloc(size);
+	memset((VOID *) tlsChannelType, 0, size);
+
+	/*
+	 * Common elements of the structure (no changes in location or name)
+	 * close2Proc, seekProc, setOptionProc stay NULL.
+	 */
+
+	tlsChannelType->typeName	= "tls";
+	tlsChannelType->closeProc	= TlsCloseProc;
+	tlsChannelType->inputProc	= TlsInputProc;
+	tlsChannelType->outputProc	= TlsOutputProc;
+	tlsChannelType->getOptionProc	= TlsGetOptionProc;
+	tlsChannelType->watchProc	= TlsWatchProc;
+	tlsChannelType->getHandleProc	= TlsGetHandleProc;
+
+	/*
+	 * blockModeProc is a twister.  We have to make some runtime-choices,
+	 * depending on the version we compiled against.
+	 */
+
+#ifdef EMULATE_CHANNEL_VERSION_2
+	/*
+	 * We are compiling against an 8.3.1- core.  We have to create some
+	 * definitions for the new elements as the compiler does not know them
+	 * by name.
+	 */
+
+	if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
+	    /*
+	     * The 'version' element of 8.3.2 is in the the place of the
+	     * blockModeProc. For 8.2.0-8.3.1 we have to set our blockModeProc
+	     * into this place.
+	     */
+	    tlsChannelType->blockModeProc = TlsBlockModeProc;
+	} else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ {
+	    /*
+	     * For the 8.3.2 core we present ourselves as a version 2
+	     * driver. This means a special value in version (ex
+	     * blockModeProc), blockModeProc in a different place and of
+	     * course usage of the handlerProc.  The last two have to
+	     * referenced with pointer magic because they aren't defined
+	     * otherwise.
+	     */
+
+	    tlsChannelType->blockModeProc =
+		(Tcl_DriverBlockModeProc*) TLS_CHANNEL_VERSION_2;
+	    (*((Tcl_DriverBlockModeProc**)(&(tlsChannelType->close2Proc)+1)))
+		= TlsBlockModeProc;
+	    (*((TlsDriverHandlerProc**)(&(tlsChannelType->close2Proc)+3)))
+		= TlsNotifyProc;
+	}
+#else
+	/*
+	 * Compiled against 8.3.2+. Direct access to all elements possible. Use
+	 * channelTypeVersion information to select the values to use.
+	 */
+
+	if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
+	    /*
+	     * The 'version' element of 8.3.2 is in the the place of the
+	     * blockModeProc. For the original patch in 8.1.x and the firstly
+	     * included (8.2) we have to set our blockModeProc into this
+	     * place.
+	     */
+	    tlsChannelType->version = (Tcl_ChannelTypeVersion)TlsBlockModeProc;
+	} else /* channelTypeVersion == TLS_CHANNEL_VERSION_2 */ {
+	    /*
+	     * For the 8.3.2 core we present ourselves as a version 2
+	     * driver. This means a special value in version (ex
+	     * blockModeProc), blockModeProc in a different place and of
+	     * course usage of the handlerProc.
+	     */
+
+	    tlsChannelType->version       = TCL_CHANNEL_VERSION_2;
+	    tlsChannelType->blockModeProc = TlsBlockModeProc;
+	    tlsChannelType->handlerProc   = TlsNotifyProc;
+	}
+#endif
+    }
+    return tlsChannelType;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsBlockModeProc --
+ *
+ *	This procedure is invoked by the generic IO level
+ *       to set blocking and nonblocking modes
+ * Results:
+ *	0 if successful, errno when failed.
+ *
+ * Side effects:
+ *	Sets the device into blocking or nonblocking mode.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+TlsBlockModeProc(ClientData instanceData,	/* Socket state. */
+                 int mode)			/* The mode to set. Can be one of
+						* TCL_MODE_BLOCKING or
+						* TCL_MODE_NONBLOCKING. */
+{
+    State *statePtr = (State *) instanceData;
+
+    if (mode == TCL_MODE_NONBLOCKING) {
+	statePtr->flags |= TLS_TCL_ASYNC;
+    } else {
+	statePtr->flags &= ~(TLS_TCL_ASYNC);
+    }
+    if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
+	return 0;
+    } else {
+	return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
+		"-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1");
+    }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsCloseProc --
+ *
+ *	This procedure is invoked by the generic IO level to perform
+ *	channel-type-specific cleanup when a SSL socket based channel
+ *	is closed.
+ *
+ *	Note: we leave the underlying socket alone, is this right?
+ *
+ * Results:
+ *	0 if successful, the value of Tcl_GetErrno() if failed.
+ *
+ * Side effects:
+ *	Closes the socket of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+TlsCloseProc(ClientData instanceData,	/* The socket to close. */
+             Tcl_Interp *interp)	/* For error reporting - unused. */
+{
+    State *statePtr = (State *) instanceData;
+
+    dprintf(stderr,"\nTlsCloseProc(0x%x)", (unsigned int) statePtr);
+
+    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;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsInputProc --
+ *
+ *	This procedure is invoked by the generic IO level
+ *       to read input from a SSL socket based channel.
+ *
+ * Results:
+ *	The number of bytes read is returned or -1 on error. An output
+ *	argument contains the POSIX error code on error, or zero if no
+ *	error occurred.
+ *
+ * Side effects:
+ *	Reads input from the input device of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+TlsInputProc(ClientData instanceData,	/* Socket state. */
+	char *buf,			/* Where to store data read. */
+	int bufSize,			/* How much space is available
+					 * in the buffer? */
+	int *errorCodePtr)		/* Where to store error code. */
+{
+    State *statePtr = (State *) instanceData;
+    int bytesRead;			/* How many bytes were read? */
+
+    *errorCodePtr = 0;
+
+    dprintf(stderr,"\nBIO_read(%d)", bufSize);
+
+    if (statePtr->flags & TLS_TCL_CALLBACK) {
+       /* don't process any bytes while verify callback is running */
+       bytesRead = 0;
+       goto input;
+    }
+
+    if (!SSL_is_init_finished(statePtr->ssl)) {
+	bytesRead = Tls_WaitForConnect(statePtr, errorCodePtr);
+	if (bytesRead <= 0) {
+	    if (*errorCodePtr == ECONNRESET) {
+		/* Soft EOF */
+		*errorCodePtr = 0;
+		bytesRead = 0;
+	    }
+	    goto input;
+	}
+    }
+    if (statePtr->flags & TLS_TCL_INIT) {
+	statePtr->flags &= ~(TLS_TCL_INIT);
+    }
+    /*
+     * We need to clear the SSL error stack now because we sometimes reach
+     * this function with leftover errors in the stack.  If BIO_read
+     * returns -1 and intends EAGAIN, there is a leftover error, it will be
+     * misconstrued as an error, not EAGAIN.
+     *
+     * Alternatively, we may want to handle the <0 return codes from
+     * BIO_read specially (as advised in the RSA docs).  TLS's lower level BIO
+     * functions play with the retry flags though, and this seems to work
+     * correctly.  Similar fix in TlsOutputProc. - hobbs
+     */
+    ERR_clear_error();
+    bytesRead = BIO_read(statePtr->bio, buf, bufSize);
+    dprintf(stderr,"\nBIO_read -> %d", bytesRead);
+
+    if (bytesRead < 0) {
+	int err = SSL_get_error(statePtr->ssl, bytesRead);
+
+	if (err == SSL_ERROR_SSL) {
+	    Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, bytesRead));
+	    *errorCodePtr = ECONNABORTED;
+	} else if (BIO_should_retry(statePtr->bio)) {
+	    dprintf(stderr,"RE! ");
+	    *errorCodePtr = EAGAIN;
+	} else {
+	    *errorCodePtr = Tcl_GetErrno();
+	    if (*errorCodePtr == ECONNRESET) {
+		/* Soft EOF */
+		*errorCodePtr = 0;
+		bytesRead = 0;
+	    }
+	}
+    }
+    input:
+    dprintf(stderr, "\nInput(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
+    return bytesRead;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsOutputProc --
+ *
+ *	This procedure is invoked by the generic IO level
+ *       to write output to a SSL socket based channel.
+ *
+ * Results:
+ *	The number of bytes written is returned. An output argument is
+ *	set to a POSIX error code if an error occurred, or zero.
+ *
+ * Side effects:
+ *	Writes output on the output device of the channel.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+TlsOutputProc(ClientData instanceData,	/* Socket state. */
+              CONST char *buf,		/* The data buffer. */
+              int toWrite,		/* How many bytes to write? */
+              int *errorCodePtr)	/* Where to store error code. */
+{
+    State *statePtr = (State *) instanceData;
+    int written, err;
+
+    *errorCodePtr = 0;
+
+    dprintf(stderr,"\nBIO_write(0x%x, %d)", (unsigned int) statePtr, toWrite);
+
+    if (statePtr->flags & TLS_TCL_CALLBACK) {
+       /* don't process any bytes while verify callback is running */
+       written = -1;
+       *errorCodePtr = EAGAIN;
+       goto output;
+    }
+
+    if (!SSL_is_init_finished(statePtr->ssl)) {
+	written = Tls_WaitForConnect(statePtr, errorCodePtr);
+	if (written <= 0) {
+	    goto output;
+	}
+    }
+    if (statePtr->flags & TLS_TCL_INIT) {
+	statePtr->flags &= ~(TLS_TCL_INIT);
+    }
+    if (toWrite == 0) {
+	dprintf(stderr, "zero-write\n");
+	BIO_flush(statePtr->bio);
+	written = 0;
+	goto output;
+    } else {
+	/*
+	 * We need to clear the SSL error stack now because we sometimes reach
+	 * this function with leftover errors in the stack.  If BIO_write
+	 * returns -1 and intends EAGAIN, there is a leftover error, it will be
+	 * misconstrued as an error, not EAGAIN.
+	 *
+	 * Alternatively, we may want to handle the <0 return codes from
+	 * BIO_write specially (as advised in the RSA docs).  TLS's lower level
+	 * BIO functions play with the retry flags though, and this seems to
+	 * work correctly.  Similar fix in TlsInputProc. - hobbs
+	 */
+	ERR_clear_error();
+	written = BIO_write(statePtr->bio, buf, toWrite);
+	dprintf(stderr,"\nBIO_write(0x%x, %d) -> [%d]",
+		(unsigned int) statePtr, toWrite, written);
+    }
+    if (written <= 0) {
+	switch ((err = SSL_get_error(statePtr->ssl, written))) {
+	    case SSL_ERROR_NONE:
+		if (written < 0) {
+		    written = 0;
+		}
+		break;
+	    case SSL_ERROR_WANT_WRITE:
+		dprintf(stderr," write W BLOCK");
+		break;
+	    case SSL_ERROR_WANT_READ:
+		dprintf(stderr," write R BLOCK");
+		break;
+	    case SSL_ERROR_WANT_X509_LOOKUP:
+		dprintf(stderr," write X BLOCK");
+		break;
+	    case SSL_ERROR_ZERO_RETURN:
+		dprintf(stderr," closed\n");
+		written = 0;
+		break;
+	    case SSL_ERROR_SYSCALL:
+		*errorCodePtr = Tcl_GetErrno();
+		dprintf(stderr," [%d] syscall errr: %d",
+			written, *errorCodePtr);
+		written = -1;
+		break;
+	    case SSL_ERROR_SSL:
+		Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written));
+		*errorCodePtr = ECONNABORTED;
+		written = -1;
+		break;
+	    default:
+		dprintf(stderr," unknown err: %d\n", err);
+		break;
+	}
+    }
+    output:
+    dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written);
+    return written;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsGetOptionProc --
+ *
+ *	Computes an option value for a SSL socket based channel, or a
+ *	list of all options and their values.
+ *
+ * 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.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+TlsGetOptionProc(ClientData instanceData,	/* Socket state. */
+	Tcl_Interp *interp,		/* For errors - can be NULL. */
+	CONST84 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;
+    }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsWatchProc --
+ *
+ *	Initialize the notifier to watch Tcl_Files from this channel.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Sets up the notifier so that a future event on the channel
+ *	will be seen by Tcl.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static void
+TlsWatchProc(ClientData instanceData,	/* The socket state. */
+             int mask)			/* Events of interest; an OR-ed
+                                         * combination of TCL_READABLE,
+                                         * TCL_WRITABLE and TCL_EXCEPTION. */
+{
+    State *statePtr = (State *) instanceData;
+
+    dprintf(stderr, "TlsWatchProc(0x%x)\n", mask);
+
+    /* Pretend to be dead as long as the verify callback is running. 
+     * Otherwise that callback could be invoked recursively. */
+    if (statePtr->flags & TLS_TCL_CALLBACK) { return; }
+
+    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);
+	}
+    }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsGetHandleProc --
+ *
+ *	Called from Tcl_GetChannelFile to retrieve o/s file handler
+ *	from the SSL socket based channel.
+ *
+ * Results:
+ *	The appropriate Tcl_File or NULL if not present. 
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+TlsGetHandleProc(ClientData instanceData,	/* The socket state. */
+                 int direction,		/* Which Tcl_File to retrieve? */
+                 ClientData *handlePtr)	/* Where to store the handle.  */
+{
+    State *statePtr = (State *) instanceData;
+
+    return Tcl_GetChannelHandle(Tls_GetParent(statePtr), direction, handlePtr);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * TlsNotifyProc --
+ *
+ *	Handler called by Tcl to inform us of activity
+ *	on the underlying channel.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May process the incoming event by itself.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+TlsNotifyProc(instanceData, mask)
+    ClientData	   instanceData; /* The state of the notified transformation */
+    int		   mask;       /* The mask of occuring events */
+{
+    State *statePtr = (State *) instanceData;
+
+    /*
+     * An event occured in the underlying channel.  This
+     * transformation doesn't process such events thus returns the
+     * incoming mask unchanged.
+     */
+
+    if (statePtr->timer != (Tcl_TimerToken) NULL) {
+	/*
+	 * Delete an existing timer. It was not fired, yet we are
+	 * here, so the channel below generated such an event and we
+	 * don't have to. The renewal of the interest after the
+	 * execution of channel handlers will eventually cause us to
+	 * recreate the timer (in WatchProc).
+	 */
+
+	Tcl_DeleteTimerHandler(statePtr->timer);
+	statePtr->timer = (Tcl_TimerToken) NULL;
+    }
+
+    if (statePtr->flags & TLS_TCL_CALLBACK) {
+	return 0;
+    }
+
+    if (statePtr->flags & TLS_TCL_INIT
+	    && !SSL_is_init_finished(statePtr->ssl)) {
+	int errorCode;
+	if (Tls_WaitForConnect(statePtr, &errorCode) <= 0
+		&& errorCode == EAGAIN) {
+	    return 0;
+	}
+    }
+
+    return mask;
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ *      TlsChannelHandler --
+ *
+ *      ------------------------------------------------*
+ *      Handler called by Tcl as a result of
+ *      Tcl_CreateChannelHandler - to inform us of activity
+ *      on the underlying channel.
+ *      ------------------------------------------------*
+ *
+ *      Sideeffects:
+ *              May generate subsequent calls to
+ *              Tcl_NotifyChannel.
+ *
+ *      Result:
+ *              None.
+ *
+ *------------------------------------------------------*
+ */
+
+static void
+TlsChannelHandler (clientData, mask)
+    ClientData     clientData;
+    int            mask;
+{
+    State *statePtr = (State *) clientData;
+
+dprintf(stderr, "HANDLER(0x%x)\n", mask);
+    Tcl_Preserve( (ClientData)statePtr);
+
+    if (mask & TCL_READABLE) {
+	BIO_set_flags(statePtr->p_bio, BIO_FLAGS_READ);
+    } else {
+	BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_READ);
+    }
+
+    if (mask & TCL_WRITABLE) {
+	BIO_set_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
+    } else {
+	BIO_clear_flags(statePtr->p_bio, BIO_FLAGS_WRITE);
+    }
+
+    mask = 0;
+    if (BIO_wpending(statePtr->bio)) {
+	mask |= TCL_WRITABLE;
+    }
+    if (BIO_pending(statePtr->bio)) {
+	mask |= TCL_READABLE;
+    }
+
+    /*
+     * The following NotifyChannel calls seems to be important, but
+     * we don't know why.  It looks like if the mask is ever non-zero
+     * that it will enter an infinite loop.
+     *
+     * Notify the upper channel of the current BIO state so the event
+     * continues to propagate up the chain.
+     *
+     * stanton: It looks like this could result in an infinite loop if
+     * the upper channel doesn't cause ChannelHandler to be removed
+     * before Tcl_NotifyChannel calls channel handlers on the lower channel.
+     */
+    
+    Tcl_NotifyChannel(statePtr->self, mask);
+    
+    if (statePtr->timer != (Tcl_TimerToken)NULL) {
+	Tcl_DeleteTimerHandler(statePtr->timer);
+	statePtr->timer = (Tcl_TimerToken)NULL;
+    }
+    if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
+	/*
+	 * Data is waiting, flush it out in short time
+	 */
+	statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
+		TlsChannelHandlerTimer, (ClientData) statePtr);
+    }
+    Tcl_Release( (ClientData)statePtr);
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ *	TlsChannelHandlerTimer --
+ *
+ *	------------------------------------------------*
+ *	Called by the notifier (-> timer) to flush out
+ *	information waiting in channel buffers.
+ *	------------------------------------------------*
+ *
+ *	Sideeffects:
+ *		As of 'TlsChannelHandler'.
+ *
+ *	Result:
+ *		None.
+ *
+ *------------------------------------------------------*
+ */
+
+static void
+TlsChannelHandlerTimer (clientData)
+ClientData clientData; /* Transformation to query */
+{
+    State *statePtr = (State *) clientData;
+    int mask = 0;
+
+    statePtr->timer = (Tcl_TimerToken) NULL;
+
+    if (BIO_wpending(statePtr->bio)) {
+	mask |= TCL_WRITABLE;
+    }
+    if (BIO_pending(statePtr->bio)) {
+	mask |= TCL_READABLE;
+    }
+    Tcl_NotifyChannel(statePtr->self, mask);
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ *	Tls_WaitForConnect --
+ *
+ *	Sideeffects:
+ *		Issues SSL_accept or SSL_connect
+ *
+ *	Result:
+ *		None.
+ *
+ *------------------------------------------------------*
+ */
+int
+Tls_WaitForConnect( statePtr, errorCodePtr)
+    State *statePtr;
+    int *errorCodePtr;		/* Where to store error code. */
+{
+    int err;
+
+    dprintf(stderr,"\nWaitForConnect(0x%x)", (unsigned int) statePtr);
+
+    if (statePtr->flags & TLS_TCL_HANDSHAKE_FAILED) {
+        /*
+         * We choose ECONNRESET over ECONNABORTED here because some server
+         * side code, on the wiki for example, sets up a read handler that
+         * does a read and if eof closes the channel. There is no catch/try
+         * around the reads so exceptions will result in potentially many
+         * dangling channels hanging around that should have been closed.
+         * (Backgroun: ECONNABORTED maps to a Tcl exception and 
+         * ECONNRESET maps to graceful EOF).
+         */
+        *errorCodePtr = ECONNRESET;
+        return -1;
+    }
+
+    for (;;) {
+	/* Not initialized yet! */
+	if (statePtr->flags & TLS_TCL_SERVER) {
+	    err = SSL_accept(statePtr->ssl);
+	} else {
+	    err = SSL_connect(statePtr->ssl);
+	}
+	/*SSL_write(statePtr->ssl, (char*)&err, 0);	HACK!!! */
+	if (err > 0) {
+	    BIO_flush(statePtr->bio);
+	}
+
+	if (err <= 0) {
+	    int rc = SSL_get_error(statePtr->ssl, err);
+
+	    if (rc == SSL_ERROR_SSL) {
+		Tls_Error(statePtr,
+			(char *)ERR_reason_error_string(ERR_get_error()));
+                statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+		*errorCodePtr = ECONNABORTED;
+		return -1;
+	    } else if (BIO_should_retry(statePtr->bio)) {
+		if (statePtr->flags & TLS_TCL_ASYNC) {
+		    dprintf(stderr,"E! ");
+		    *errorCodePtr = EAGAIN;
+		    return -1;
+		} else {
+		    continue;
+		}
+	    } else if (err == 0) {
+		dprintf(stderr,"CR! ");
+		*errorCodePtr = ECONNRESET;
+		return -1;
+	    }
+	    if (statePtr->flags & TLS_TCL_SERVER) {
+		err = SSL_get_verify_result(statePtr->ssl);
+		if (err != X509_V_OK) {
+		    Tls_Error(statePtr,
+			    (char *)X509_verify_cert_error_string(err));
+                    statePtr->flags |= TLS_TCL_HANDSHAKE_FAILED;
+		    *errorCodePtr = ECONNABORTED;
+		    return -1;
+		}
+	    }
+	    *errorCodePtr = Tcl_GetErrno();
+	    dprintf(stderr,"ERR(%d, %d) ", rc, *errorCodePtr);
+	    return -1;
+	}
+	dprintf(stderr,"R0! ");
+	return 1;
+    }
+}
+
+Tcl_Channel
+Tls_GetParent( statePtr )
+    State *statePtr;
+{
+    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 <matt@sensus.org>.
+		 *
+		 * 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);
+    }
+}