Merge commit 'ea8141157cab7d1b2f6cff5463988d1f68f66db3' as 'tls'

1 files changed, 1833 insertions, 0 deletions

diff --git a/tls/tls.c b/tls/tls.c
new file mode 100644
index 0000000..dd95e93
--- /dev/null
+++ b/tls/tls.c
@@ -0,0 +1,1833 @@
+/*
+ * Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com>
+ * some modifications:
+ *	Copyright (C) 2000 Ajuba Solutions
+ *	Copyright (C) 2002 ActiveState Corporation
+ *	Copyright (C) 2004 Starfish Systems 
+ *
+ * $Header: /cvsroot/tls/tls/tls.c,v 1.37 2015/07/07 17:16:02 andreas_kupries 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
+ * 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"
+#include "tclOpts.h"
+#include <stdlib.h>
+
+/*
+ * External functions
+ */
+
+/*
+ * Forward declarations
+ */
+
+#define F2N( key, dsp) \
+	(((key) == NULL) ? (char *) NULL : \
+		Tcl_TranslateFileName(interp, (key), (dsp)))
+#define REASON()	ERR_reason_error_string(ERR_get_error())
+
+static void	InfoCallback _ANSI_ARGS_ ((CONST SSL *ssl, int where, int ret));
+
+static int	CiphersObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static int	HandshakeObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static int	ImportObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static int	StatusObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static int	VersionObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static int	MiscObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static int	UnimportObjCmd _ANSI_ARGS_ ((ClientData clientData,
+			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
+
+static SSL_CTX *CTX_Init _ANSI_ARGS_((State *statePtr, int proto, char *key,
+			char *cert, char *CAdir, char *CAfile, char *ciphers,
+			char *DHparams));
+
+static int	TlsLibInit _ANSI_ARGS_ (()) ;
+
+#define TLS_PROTO_SSL2		0x01
+#define TLS_PROTO_SSL3		0x02
+#define TLS_PROTO_TLS1		0x04
+#define TLS_PROTO_TLS1_1	0x08
+#define TLS_PROTO_TLS1_2	0x10
+#define ENABLED(flag, mask)	(((flag) & (mask)) == (mask))
+
+/*
+ * Static data structures
+ */
+
+#ifndef OPENSSL_NO_DH
+/* code derived from output of 'openssl dhparam -C 2048' */
+
+static unsigned char dh2048_p[]={
+	0xEC,0xFD,0x6F,0x66,0xD8,0xBC,0xB4,0xCB,0xD7,0xE7,0xB4,0xAE,
+	0xEC,0xC0,0x06,0x25,0x40,0x9F,0x3F,0xC4,0xAC,0x34,0x19,0x36,
+	0x8A,0xAB,0xA9,0xF6,0x45,0x36,0x87,0x1F,0x10,0x35,0x3F,0x90,
+	0x00,0xC6,0x7A,0xE8,0x51,0xF4,0x7F,0x50,0x0F,0xC2,0x82,0x91,
+	0xAD,0x60,0x1B,0x49,0xB1,0x0B,0x23,0xC3,0x37,0xAE,0x0D,0x2C,
+	0x49,0xC6,0xFB,0x60,0x9D,0x50,0x2F,0x8C,0x2F,0xDE,0xE6,0x5F,
+	0x53,0x8B,0x5F,0xF9,0x70,0x16,0xEE,0x51,0xD1,0xAB,0x02,0x48,
+	0x61,0xF1,0xA0,0xD7,0xBD,0x04,0x24,0xF0,0xE4,0xD1,0x0A,0x4C,
+	0x28,0xDC,0x22,0x78,0x7C,0xED,0x2A,0xFA,0xF4,0x57,0x7C,0xAE,
+	0xDF,0x52,0xC6,0xA2,0x11,0x28,0xC5,0x3B,0xB8,0x2F,0x95,0x3F,
+	0x1E,0x05,0x66,0xFE,0x7D,0x1A,0x73,0xA0,0x45,0xF8,0xBB,0x8C,
+	0x64,0xB9,0xA9,0x4D,0x23,0xBE,0x20,0x60,0xA2,0xF7,0xC7,0xD8,
+	0xD8,0x49,0x28,0x9A,0x81,0xAC,0xF9,0x7F,0x3C,0xFC,0xBE,0x25,
+	0x5B,0x1D,0xB6,0xAB,0x08,0x06,0x11,0x8D,0x94,0x69,0x3C,0x68,
+	0x98,0x5A,0x90,0xF8,0xEB,0x19,0xCA,0x9F,0x1C,0x50,0x96,0x53,
+	0xEF,0xEC,0x1B,0x93,0x4F,0x53,0xB7,0xD9,0x04,0x8E,0x48,0x99,
+	0x6E,0x24,0xFF,0x66,0xF5,0xB0,0xDF,0x00,0xBA,0x22,0xE2,0xB6,
+	0xE3,0x3A,0xC2,0x95,0xB1,0x14,0x68,0xFB,0xA5,0x37,0x22,0x78,
+	0x56,0x5C,0xA4,0x23,0x31,0x02,0x97,0x7D,0xA9,0x84,0x0B,0x12,
+	0x26,0x58,0x2F,0x86,0x10,0xAD,0xB0,0xAB,0xB9,0x7B,0x05,0x9A,
+	0xDE,0x11,0xF1,0xE7,0x34,0xC7,0x95,0x42,0x1C,0x4F,0xA9,0xA8,
+	0x92,0xDF,0x3F,0x7B,
+	};
+static unsigned char dh2048_g[]={
+	0x02,
+};
+
+
+static DH *get_dh2048()
+{
+    DH *dh=NULL;
+
+    if ((dh=DH_new()) == NULL) return(NULL);
+
+    dh->p=BN_bin2bn(dh2048_p,sizeof(dh2048_p),NULL);
+    dh->g=BN_bin2bn(dh2048_g,sizeof(dh2048_g),NULL);
+
+    if ((dh->p == NULL) || (dh->g == NULL))
+	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.
+ */
+
+#ifdef BSAFE
+#define PRE_OPENSSL_0_9_4 1
+#endif
+
+/*
+ * Pre OpenSSL 0.9.4 Compat
+ */
+
+#ifndef STACK_OF
+#define STACK_OF(x)			STACK
+#define sk_SSL_CIPHER_num(sk)		sk_num((sk))
+#define sk_SSL_CIPHER_value( sk, index)	(SSL_CIPHER*)sk_value((sk), (index))
+#endif
+
+/*
+ * Thread-Safe TLS Code
+ */
+
+#ifdef TCL_THREADS
+#define OPENSSL_THREAD_DEFINES
+#include <openssl/opensslconf.h>
+
+#ifdef OPENSSL_THREADS
+#include <openssl/crypto.h>
+
+/*
+ * Threaded operation requires locking callbacks
+ * Based from /crypto/cryptlib.c of OpenSSL and NSOpenSSL.
+ */
+
+static Tcl_Mutex locks[CRYPTO_NUM_LOCKS];
+static Tcl_Mutex init_mx;
+static int initialized;
+
+static void          CryptoThreadLockCallback (int mode, int n, const char *file, int line);
+static unsigned long CryptoThreadIdCallback   (void);
+
+static void
+CryptoThreadLockCallback(int mode, int n, const char *file, int line)
+{
+    if (mode & CRYPTO_LOCK) {
+       Tcl_MutexLock(&locks[n]);
+    } else {
+       Tcl_MutexUnlock(&locks[n]);
+    }
+}
+
+static unsigned long
+CryptoThreadIdCallback(void)
+{
+    return (unsigned long) Tcl_GetCurrentThread();
+}
+#endif /* OPENSSL_THREADS */
+#endif /* TCL_THREADS */
+
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * InfoCallback --
+ *
+ *	monitors SSL connection process
+ *
+ * Results:
+ *	None
+ *
+ * Side effects:
+ *	Calls callback (if defined)
+ *-------------------------------------------------------------------
+ */
+static void
+InfoCallback(CONST SSL *ssl, int where, int ret)
+{
+    State *statePtr = (State*)SSL_get_app_data((SSL *)ssl);
+    Tcl_Obj *cmdPtr;
+    char *major; char *minor;
+
+    if (statePtr->callback == (Tcl_Obj*)NULL)
+	return;
+
+    cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+
+#if 0
+    if (where & SSL_CB_ALERT) {
+	sev = SSL_alert_type_string_long(ret);
+	if (strcmp( sev, "fatal")==0) {	/* Map to error */
+	    Tls_Error(statePtr, SSL_ERROR(ssl, 0));
+	    return;
+	}
+    }
+#endif
+    if (where & SSL_CB_HANDSHAKE_START) {
+	major = "handshake";
+	minor = "start";
+    } else if (where & SSL_CB_HANDSHAKE_DONE) {
+	major = "handshake";
+	minor = "done";
+    } else {
+	if (where & SSL_CB_ALERT)		major = "alert";
+	else if (where & SSL_ST_CONNECT)	major = "connect";
+	else if (where & SSL_ST_ACCEPT)		major = "accept";
+	else					major = "unknown";
+
+	if (where & SSL_CB_READ)		minor = "read";
+	else if (where & SSL_CB_WRITE)		minor = "write";
+	else if (where & SSL_CB_LOOP)		minor = "loop";
+	else if (where & SSL_CB_EXIT)		minor = "exit";
+	else					minor = "unknown";
+    }
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
+	    Tcl_NewStringObj( "info", -1));
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
+	    Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) );
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj( major, -1) );
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj( minor, -1) );
+
+    if (where & (SSL_CB_LOOP|SSL_CB_EXIT)) {
+	Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj( SSL_state_string_long(ssl), -1) );
+    } else if (where & SSL_CB_ALERT) {
+	CONST char *cp = (char *) SSL_alert_desc_string_long(ret);
+
+	Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj( cp, -1) );
+    } else {
+	Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj( SSL_state_string_long(ssl), -1) );
+    }
+    Tcl_Preserve( (ClientData) statePtr->interp);
+    Tcl_Preserve( (ClientData) statePtr);
+
+    Tcl_IncrRefCount( cmdPtr);
+    (void) Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL);
+    Tcl_DecrRefCount( cmdPtr);
+
+    Tcl_Release( (ClientData) statePtr);
+    Tcl_Release( (ClientData) statePtr->interp);
+
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * VerifyCallback --
+ *
+ *	Monitors SSL certificate validation process.
+ *	This is called whenever a certificate is inspected
+ *	or decided invalid.
+ *
+ * Results:
+ *	A callback bound to the socket may return one of:
+ *	    0			- the certificate is deemed invalid
+ *	    1			- the certificate is deemed valid
+ *	    empty string	- no change to certificate validation
+ *
+ * Side effects:
+ *	The err field of the currently operative State is set
+ *	  to a string describing the SSL negotiation failure reason
+ *-------------------------------------------------------------------
+ */
+static int
+VerifyCallback(int ok, X509_STORE_CTX *ctx)
+{
+    Tcl_Obj *cmdPtr, *result;
+    char *errStr, *string;
+    int length;
+    SSL   *ssl		= (SSL*)X509_STORE_CTX_get_app_data(ctx);
+    X509  *cert		= X509_STORE_CTX_get_current_cert(ctx);
+    State *statePtr	= (State*)SSL_get_app_data(ssl);
+    int depth		= X509_STORE_CTX_get_error_depth(ctx);
+    int err		= X509_STORE_CTX_get_error(ctx);
+
+    dprintf(stderr, "Verify: %d\n", ok);
+
+    if (!ok) {
+	errStr = (char*)X509_verify_cert_error_string(err);
+    } else {
+	errStr = (char *)0;
+    }
+
+    if (statePtr->callback == (Tcl_Obj*)NULL) {
+	if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
+	    return ok;
+	} else {
+	    return 1;
+	}
+    }
+    cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
+	    Tcl_NewStringObj( "verify", -1));
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
+	    Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) );
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewIntObj( depth) );
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tls_NewX509Obj( statePtr->interp, cert) );
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewIntObj( ok) );
+
+    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj( errStr ? errStr : "", -1) );
+
+    Tcl_Preserve( (ClientData) statePtr->interp);
+    Tcl_Preserve( (ClientData) statePtr);
+
+    statePtr->flags |= TLS_TCL_CALLBACK;
+
+    Tcl_IncrRefCount( cmdPtr);
+    if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
+	/* It got an error - reject the certificate.		*/
+	Tcl_BackgroundError( statePtr->interp);
+	ok = 0;
+    } else {
+	result = Tcl_GetObjResult(statePtr->interp);
+	string = Tcl_GetStringFromObj(result, &length);
+	/* An empty result leaves verification unchanged.	*/
+	if (length > 0) {
+	    if (Tcl_GetIntFromObj(statePtr->interp, result, &ok) != TCL_OK) {
+		Tcl_BackgroundError(statePtr->interp);
+		ok = 0;
+	    }
+	}
+    }
+    Tcl_DecrRefCount( cmdPtr);
+
+    statePtr->flags &= ~(TLS_TCL_CALLBACK);
+
+    Tcl_Release( (ClientData) statePtr);
+    Tcl_Release( (ClientData) statePtr->interp);
+
+    return(ok);	/* By default, leave verification unchanged.	*/
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Error --
+ *
+ *	Calls callback with $fd and $msg - so the callback can decide
+ *	what to do with errors.
+ *
+ * Side effects:
+ *	The err field of the currently operative State is set
+ *	  to a string describing the SSL negotiation failure reason
+ *-------------------------------------------------------------------
+ */
+void
+Tls_Error(State *statePtr, char *msg)
+{
+    Tcl_Obj *cmdPtr;
+
+    if (msg && *msg) {
+	Tcl_SetErrorCode(statePtr->interp, "SSL", msg, (char *)NULL);
+    } else {
+	msg = Tcl_GetStringFromObj(Tcl_GetObjResult(statePtr->interp), NULL);
+    }
+    statePtr->err = msg;
+
+    if (statePtr->callback == (Tcl_Obj*)NULL) {
+	char buf[BUFSIZ];
+	sprintf(buf, "SSL channel \"%s\": error: %s",
+	    Tcl_GetChannelName(statePtr->self), msg);
+	Tcl_SetResult( statePtr->interp, buf, TCL_VOLATILE);
+	Tcl_BackgroundError( statePtr->interp);
+	return;
+    }
+    cmdPtr = Tcl_DuplicateObj(statePtr->callback);
+
+    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 
+	    Tcl_NewStringObj("error", -1));
+
+    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 
+	    Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));
+
+    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
+	    Tcl_NewStringObj(msg, -1));
+
+    Tcl_Preserve((ClientData) statePtr->interp);
+    Tcl_Preserve((ClientData) statePtr);
+
+    Tcl_IncrRefCount(cmdPtr);
+    if (Tcl_EvalObjEx(statePtr->interp, cmdPtr, TCL_EVAL_GLOBAL) != TCL_OK) {
+	Tcl_BackgroundError(statePtr->interp);
+    }
+    Tcl_DecrRefCount(cmdPtr);
+
+    Tcl_Release((ClientData) statePtr);
+    Tcl_Release((ClientData) statePtr->interp);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * PasswordCallback -- 
+ *
+ *	Called when a password is needed to unpack RSA and PEM keys.
+ *	Evals any bound password script and returns the result as
+ *	the password string.
+ *-------------------------------------------------------------------
+ */
+#ifdef PRE_OPENSSL_0_9_4
+/*
+ * No way to handle user-data therefore no way without a global
+ * variable to access the Tcl interpreter.
+*/
+static int
+PasswordCallback(char *buf, int size, int verify)
+{
+    return -1;
+}
+#else
+static int
+PasswordCallback(char *buf, int size, int verify, void *udata)
+{
+    State *statePtr	= (State *) udata;
+    Tcl_Interp *interp	= statePtr->interp;
+    Tcl_Obj *cmdPtr;
+    int result;
+
+    if (statePtr->password == NULL) {
+	if (Tcl_EvalEx(interp, "tls::password", -1, TCL_EVAL_GLOBAL)
+		== TCL_OK) {
+	    char *ret = (char *) Tcl_GetStringResult(interp);
+	    strncpy(buf, ret, (size_t) size);
+	    return (int)strlen(ret);
+	} else {
+	    return -1;
+	}
+    }
+
+    cmdPtr = Tcl_DuplicateObj(statePtr->password);
+
+    Tcl_Preserve((ClientData) statePtr->interp);
+    Tcl_Preserve((ClientData) statePtr);
+
+    Tcl_IncrRefCount(cmdPtr);
+    result = Tcl_EvalObjEx(interp, cmdPtr, TCL_EVAL_GLOBAL);
+    if (result != TCL_OK) {
+	Tcl_BackgroundError(statePtr->interp);
+    }
+    Tcl_DecrRefCount(cmdPtr);
+
+    Tcl_Release((ClientData) statePtr);
+    Tcl_Release((ClientData) statePtr->interp);
+
+    if (result == TCL_OK) {
+	char *ret = (char *) Tcl_GetStringResult(interp);
+	strncpy(buf, ret, (size_t) size);
+	return (int)strlen(ret);
+    } else {
+	return -1;
+    }
+}
+#endif
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * CiphersObjCmd -- list available ciphers
+ *
+ *	This procedure is invoked to process the "tls::ciphers" command
+ *	to list available ciphers, based upon protocol selected.
+ *
+ * Results:
+ *	A standard Tcl result list.
+ *
+ * Side effects:
+ *	constructs and destroys SSL context (CTX)
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+CiphersObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj	*CONST objv[];
+{
+    static CONST84 char *protocols[] = {
+	"ssl2",	"ssl3",	"tls1",	"tls1.1", "tls1.2", NULL
+    };
+    enum protocol {
+	TLS_SSL2, TLS_SSL3, TLS_TLS1, TLS_TLS1_1, TLS_TLS1_2, TLS_NONE
+    };
+    Tcl_Obj *objPtr;
+    SSL_CTX *ctx = NULL;
+    SSL *ssl = NULL;
+    STACK_OF(SSL_CIPHER) *sk;
+    char *cp, buf[BUFSIZ];
+    int index, verbose = 0;
+
+    if (objc < 2 || objc > 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "protocol ?verbose?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj( interp, objv[1], protocols, "protocol", 0,
+	&index) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    if (objc > 2 && Tcl_GetBooleanFromObj( interp, objv[2],
+	&verbose) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    switch ((enum protocol)index) {
+    case TLS_SSL2:
+#if defined(NO_SSL2)
+		Tcl_AppendResult(interp, "protocol not supported", NULL);
+		return TCL_ERROR;
+#else
+		ctx = SSL_CTX_new(SSLv2_method()); break;
+#endif
+    case TLS_SSL3:
+#if defined(NO_SSL3)
+		Tcl_AppendResult(interp, "protocol not supported", NULL);
+		return TCL_ERROR;
+#else
+		ctx = SSL_CTX_new(SSLv3_method()); break;
+#endif
+    case TLS_TLS1:
+#if defined(NO_TLS1)
+		Tcl_AppendResult(interp, "protocol not supported", NULL);
+		return TCL_ERROR;
+#else
+		ctx = SSL_CTX_new(TLSv1_method()); break;
+#endif
+    case TLS_TLS1_1:
+#if defined(NO_TLS1_1)
+		Tcl_AppendResult(interp, "protocol not supported", NULL);
+		return TCL_ERROR;
+#else
+		ctx = SSL_CTX_new(TLSv1_1_method()); break;
+#endif
+    case TLS_TLS1_2:
+#if defined(NO_TLS1_2)
+		Tcl_AppendResult(interp, "protocol not supported", NULL);
+		return TCL_ERROR;
+#else
+		ctx = SSL_CTX_new(TLSv1_2_method()); break;
+#endif
+    default:
+		break;
+    }
+    if (ctx == NULL) {
+	Tcl_AppendResult(interp, REASON(), (char *) NULL);
+	return TCL_ERROR;
+    }
+    ssl = SSL_new(ctx);
+    if (ssl == NULL) {
+	Tcl_AppendResult(interp, REASON(), (char *) NULL);
+	SSL_CTX_free(ctx);
+	return TCL_ERROR;
+    }
+    objPtr = Tcl_NewListObj( 0, NULL);
+
+    if (!verbose) {
+	for (index = 0; ; index++) {
+	    cp = (char*)SSL_get_cipher_list( ssl, index);
+	    if (cp == NULL) break;
+	    Tcl_ListObjAppendElement( interp, objPtr,
+		Tcl_NewStringObj( cp, -1) );
+	}
+    } else {
+	sk = SSL_get_ciphers(ssl);
+
+	for (index = 0; index < sk_SSL_CIPHER_num(sk); index++) {
+	    register size_t i;
+	    SSL_CIPHER_description( sk_SSL_CIPHER_value( sk, index),
+				    buf, sizeof(buf));
+	    for (i = strlen(buf) - 1; i ; i--) {
+		if (buf[i] == ' ' || buf[i] == '\n' ||
+		    buf[i] == '\r' || buf[i] == '\t') {
+		    buf[i] = '\0';
+		} else {
+		    break;
+		}
+	    }
+	    Tcl_ListObjAppendElement( interp, objPtr,
+		Tcl_NewStringObj( buf, -1) );
+	}
+    }
+    SSL_free(ssl);
+    SSL_CTX_free(ctx);
+
+    Tcl_SetObjResult( interp, objPtr);
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * HandshakeObjCmd --
+ *
+ *	This command is used to verify whether the handshake is complete
+ *	or not.
+ *
+ * Results:
+ *	A standard Tcl result. 1 means handshake complete, 0 means pending.
+ *
+ * Side effects:
+ *	May force SSL negotiation to take place.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+HandshakeObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj *CONST objv[];
+{
+    Tcl_Channel chan;		/* The channel to set a mode on. */
+    State *statePtr;		/* client state for ssl socket */
+    int ret = 1;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "channel");
+	return TCL_ERROR;
+    }
+
+    chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
+    if (chan == (Tcl_Channel) NULL) {
+	return TCL_ERROR;
+    }
+    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;
+    }
+    statePtr = (State *)Tcl_GetChannelInstanceData(chan);
+
+    if (!SSL_is_init_finished(statePtr->ssl)) {
+	int err;
+	ret = Tls_WaitForConnect(statePtr, &err);
+	if ((statePtr->flags & TLS_TCL_ASYNC) && err == EAGAIN) {
+	    ret = 0;
+	}
+	if (ret < 0) {
+	    CONST char *errStr = statePtr->err;
+	    Tcl_ResetResult(interp);
+	    Tcl_SetErrno(err);
+
+	    if (!errStr || *errStr == 0) {
+		errStr = Tcl_PosixError(interp);
+	    }
+
+	    Tcl_AppendResult(interp, "handshake failed: ", errStr,
+		    (char *) NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * ImportObjCmd --
+ *
+ *	This procedure is invoked to process the "ssl" command
+ *
+ *	The ssl command pushes SSL over a (newly connected) tcp socket
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	May modify the behavior of an IO channel.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+ImportObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj *CONST objv[];
+{
+    Tcl_Channel chan;		/* The channel to set a mode on. */
+    State *statePtr;		/* client state for ssl socket */
+    SSL_CTX *ctx	= NULL;
+    Tcl_Obj *script	= NULL;
+    Tcl_Obj *password	= NULL;
+    int idx, len;
+    int flags		= TLS_TCL_INIT;
+    int server		= 0;	/* is connection incoming or outgoing? */
+    char *key		= NULL;
+    char *cert		= NULL;
+    char *ciphers	= NULL;
+    char *CAfile	= NULL;
+    char *CAdir		= NULL;
+    char *DHparams	= NULL;
+    char *model		= NULL;
+#ifndef OPENSSL_NO_TLSEXT
+    char *servername	= NULL;	/* hostname for Server Name Indication */
+#endif
+#if defined(NO_SSL2)
+    int ssl2 = 0;
+#else
+    int ssl2 = 1;
+#endif
+#if defined(NO_SSL3)
+    int ssl3 = 0;
+#else
+    int ssl3 = 1;
+#endif
+    int tls1 = 1;
+    int tls1_1 = 1;
+    int tls1_2 = 1;
+    int proto = 0;
+    int verify = 0, require = 0, request = 1;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "channel ?options?");
+	return TCL_ERROR;
+    }
+
+    chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
+    if (chan == (Tcl_Channel) NULL) {
+	return TCL_ERROR;
+    }
+    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] != '-')
+	    break;
+
+	OPTSTR( "-cadir", CAdir);
+	OPTSTR( "-cafile", CAfile);
+	OPTSTR( "-certfile", cert);
+	OPTSTR( "-cipher", ciphers);
+	OPTOBJ( "-command", script);
+	OPTSTR( "-dhparams", DHparams);
+	OPTSTR( "-keyfile", key);
+	OPTSTR( "-model", model);
+	OPTOBJ( "-password", password);
+	OPTBOOL( "-require", require);
+	OPTBOOL( "-request", request);
+	OPTBOOL( "-server", server);
+#ifndef OPENSSL_NO_TLSEXT
+        OPTSTR( "-servername", servername);
+#endif
+
+	OPTBOOL( "-ssl2", ssl2);
+	OPTBOOL( "-ssl3", ssl3);
+	OPTBOOL( "-tls1", tls1);
+	OPTBOOL( "-tls1.1", tls1_1);
+	OPTBOOL( "-tls1.2", tls1_2);
+
+	OPTBAD( "option", "-cadir, -cafile, -certfile, -cipher, -command, -dhparams, -keyfile, -model, -password, -require, -request, -server, -servername, -ssl2, -ssl3, -tls1, -tls1.1 or -tls1.2");
+
+	return TCL_ERROR;
+    }
+    if (request)	    verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
+    if (request && require) verify |= SSL_VERIFY_FAIL_IF_NO_PEER_CERT;
+    if (verify == 0)	verify = SSL_VERIFY_NONE;
+
+    proto |= (ssl2 ? TLS_PROTO_SSL2 : 0);
+    proto |= (ssl3 ? TLS_PROTO_SSL3 : 0);
+    proto |= (tls1 ? TLS_PROTO_TLS1 : 0);
+    proto |= (tls1_1 ? TLS_PROTO_TLS1_1 : 0);
+    proto |= (tls1_2 ? TLS_PROTO_TLS1_2 : 0);
+
+    /* reset to NULL if blank string provided */
+    if (cert && !*cert)		cert	 = NULL;
+    if (key && !*key)		key	 = NULL;
+    if (ciphers && !*ciphers)	ciphers	 = NULL;
+    if (CAfile && !*CAfile)	CAfile	 = NULL;
+    if (CAdir && !*CAdir)	CAdir	 = NULL;
+    if (DHparams && !*DHparams)	DHparams = NULL;
+
+    /* new SSL state */
+    statePtr		= (State *) ckalloc((unsigned) sizeof(State));
+    memset(statePtr, 0, sizeof(State));
+
+    statePtr->flags	= flags;
+    statePtr->interp	= interp;
+    statePtr->vflags	= verify;
+    statePtr->err	= "";
+
+    /* allocate script */
+    if (script) {
+	(void) Tcl_GetStringFromObj(script, &len);
+	if (len) {
+	    statePtr->callback = script;
+	    Tcl_IncrRefCount(statePtr->callback);
+	}
+    }
+
+    /* allocate password */
+    if (password) {
+	(void) Tcl_GetStringFromObj(password, &len);
+	if (len) {
+	    statePtr->password = password;
+	    Tcl_IncrRefCount(statePtr->password);
+	}
+    }
+
+    if (model != NULL) {
+	int mode;
+	/* Get the "model" context */
+	chan = Tcl_GetChannel(interp, model, &mode);
+	if (chan == (Tcl_Channel) NULL) {
+	    Tls_Free((char *) statePtr);
+	    return TCL_ERROR;
+	}
+	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);
+	    Tls_Free((char *) statePtr);
+	    return TCL_ERROR;
+	}
+	ctx = ((State *)Tcl_GetChannelInstanceData(chan))->ctx;
+    } else {
+	if ((ctx = CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers,
+		DHparams)) == (SSL_CTX*)0) {
+	    Tls_Free((char *) statePtr);
+	    return TCL_ERROR;
+	}
+    }
+
+    statePtr->ctx = ctx;
+
+    /*
+     * We need to make sure that the channel works in binary (for the
+     * 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");
+    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);
+	return TCL_ERROR;
+    }
+
+    /*
+     * SSL Initialization
+     */
+
+    statePtr->ssl = SSL_new(statePtr->ctx);
+    if (!statePtr->ssl) {
+	/* SSL library error */
+	Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(),
+		(char *) NULL);
+	Tls_Free((char *) statePtr);
+	return TCL_ERROR;
+    }
+
+#ifndef OPENSSL_NO_TLSEXT
+    if (servername) {
+        if (!SSL_set_tlsext_host_name(statePtr->ssl, servername) && require) {
+            Tcl_AppendResult(interp, "setting TLS host name extension failed",
+                (char *) NULL);
+            Tls_Free((char *) statePtr);
+            return TCL_ERROR;
+        }
+    }
+#endif
+
+    /*
+     * SSL Callbacks
+     */
+
+    SSL_set_app_data(statePtr->ssl, (VOID *)statePtr);	/* point back to us */
+
+    SSL_set_verify(statePtr->ssl, verify, VerifyCallback);
+
+    SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);
+
+    /* Create Tcl_Channel BIO Handler */
+    statePtr->p_bio	= BIO_new_tcl(statePtr, BIO_CLOSE);
+    statePtr->bio	= BIO_new(BIO_f_ssl());
+
+    if (server) {
+	statePtr->flags |= TLS_TCL_SERVER;
+	SSL_set_accept_state(statePtr->ssl);
+    } else {
+	SSL_set_connect_state(statePtr->ssl);
+    }
+    SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio);
+    BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_NOCLOSE);
+
+    /*
+     * End of SSL Init
+     */
+    Tcl_SetResult(interp, (char *) Tcl_GetChannelName(statePtr->self),
+	    TCL_VOLATILE);
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * UnimportObjCmd --
+ *
+ *	This procedure is invoked to remove the topmost channel filter.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	May modify the behavior of an IO channel.
+ *
+ *-------------------------------------------------------------------
+ */
+
+static int
+UnimportObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj *CONST objv[];
+{
+    Tcl_Channel chan;		/* The channel to set a mode on. */
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "channel");
+	return TCL_ERROR;
+    }
+
+    chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL);
+    if (chan == (Tcl_Channel) NULL) {
+	return TCL_ERROR;
+    }
+
+    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;
+    }
+
+    if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) {
+	return TCL_ERROR;
+    }
+
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * CTX_Init -- construct a SSL_CTX instance
+ *
+ * Results:
+ *	A valid SSL_CTX instance or NULL.
+ *
+ * Side effects:
+ *	constructs SSL context (CTX)
+ *
+ *-------------------------------------------------------------------
+ */
+
+static SSL_CTX *
+CTX_Init(statePtr, proto, key, cert, CAdir, CAfile, ciphers, DHparams)
+    State *statePtr;
+    int proto;
+    char *key;
+    char *cert;
+    char *CAdir;
+    char *CAfile;
+    char *ciphers;
+    char *DHparams;
+{
+    Tcl_Interp *interp = statePtr->interp;
+    SSL_CTX *ctx = NULL;
+    Tcl_DString ds;
+    Tcl_DString ds1;
+    int off = 0;
+    const SSL_METHOD *method;
+
+    if (!proto) {
+	Tcl_AppendResult(interp, "no valid protocol selected", NULL);
+	return (SSL_CTX *)0;
+    }
+
+    /* create SSL context */
+#if defined(NO_SSL2)
+    if (ENABLED(proto, TLS_PROTO_SSL2)) {
+	Tcl_AppendResult(interp, "protocol not supported", NULL);
+	return (SSL_CTX *)0;
+    }
+#endif
+#if defined(NO_SSL3)
+    if (ENABLED(proto, TLS_PROTO_SSL3)) {
+	Tcl_AppendResult(interp, "protocol not supported", NULL);
+	return (SSL_CTX *)0;
+    }
+#endif
+#if defined(NO_TLS1)
+    if (ENABLED(proto, TLS_PROTO_TLS1)) {
+	Tcl_AppendResult(interp, "protocol not supported", NULL);
+	return (SSL_CTX *)0;
+    }
+#endif
+#if defined(NO_TLS1_1)
+    if (ENABLED(proto, TLS_PROTO_TLS1_1)) {
+	Tcl_AppendResult(interp, "protocol not supported", NULL);
+	return (SSL_CTX *)0;
+    }
+#endif
+#if defined(NO_TLS1_2)
+    if (ENABLED(proto, TLS_PROTO_TLS1_2)) {
+	Tcl_AppendResult(interp, "protocol not supported", NULL);
+	return (SSL_CTX *)0;
+    }
+#endif
+
+    switch (proto) {
+#if !defined(NO_SSL2)
+    case TLS_PROTO_SSL2:
+	method = SSLv2_method ();
+	break;
+#endif
+#if !defined(NO_SSL3)
+    case TLS_PROTO_SSL3:
+	method = SSLv3_method ();
+	break;
+#endif
+#if !defined(NO_TLS1)
+    case TLS_PROTO_TLS1:
+	method = TLSv1_method ();
+	break;
+#endif
+#if !defined(NO_TLS1_1)
+    case TLS_PROTO_TLS1_1:
+	method = TLSv1_1_method ();
+	break;
+#endif
+#if !defined(NO_TLS1_2)
+    case TLS_PROTO_TLS1_2:
+	method = TLSv1_2_method ();
+	break;
+#endif
+    default:
+        method = SSLv23_method ();
+#if !defined(NO_SSL2)
+	off |= (ENABLED(proto, TLS_PROTO_SSL2)   ? 0 : SSL_OP_NO_SSLv2);
+#endif
+#if !defined(NO_SSL3)
+	off |= (ENABLED(proto, TLS_PROTO_SSL3)   ? 0 : SSL_OP_NO_SSLv3);
+#endif
+#if !defined(NO_TLS1)
+	off |= (ENABLED(proto, TLS_PROTO_TLS1)   ? 0 : SSL_OP_NO_TLSv1);
+#endif
+#if !defined(NO_TLS1_1)
+	off |= (ENABLED(proto, TLS_PROTO_TLS1_1) ? 0 : SSL_OP_NO_TLSv1_1);
+#endif
+#if !defined(NO_TLS1_2)
+	off |= (ENABLED(proto, TLS_PROTO_TLS1_2) ? 0 : SSL_OP_NO_TLSv1_2);
+#endif
+	break;
+    }
+    
+    ctx = SSL_CTX_new (method);
+    
+    SSL_CTX_set_app_data( ctx, (VOID*)interp);	/* remember the interpreter */
+    SSL_CTX_set_options( ctx, SSL_OP_ALL);	/* all SSL bug workarounds */
+    SSL_CTX_set_options( ctx, off);	/* all SSL bug workarounds */
+    SSL_CTX_sess_set_cache_size( ctx, 128);
+
+    if (ciphers != NULL)
+	SSL_CTX_set_cipher_list(ctx, ciphers);
+
+    /* set some callbacks */
+    SSL_CTX_set_default_passwd_cb(ctx, PasswordCallback);
+
+#ifndef BSAFE
+    SSL_CTX_set_default_passwd_cb_userdata(ctx, (void *)statePtr);
+#endif
+
+    /* read a Diffie-Hellman parameters file, or use the built-in one */
+#ifdef OPENSSL_NO_DH
+    if (DHparams != NULL) {
+	Tcl_AppendResult(interp,
+	    "DH parameter support not available", (char *) NULL);
+	SSL_CTX_free(ctx);
+	return (SSL_CTX *)0;
+    }
+#else
+    {
+	DH* dh;
+	if (DHparams != NULL) {
+	    BIO *bio;
+	    Tcl_DStringInit(&ds);
+	    bio = BIO_new_file(F2N(DHparams, &ds), "r");
+	    if (!bio) {
+		Tcl_DStringFree(&ds);
+		Tcl_AppendResult(interp,
+		    "Could not find DH parameters file", (char *) NULL);
+		SSL_CTX_free(ctx);
+		return (SSL_CTX *)0;
+	    }
+	    
+	    dh = PEM_read_bio_DHparams(bio, NULL, NULL, NULL);
+	    BIO_free(bio);
+	    Tcl_DStringFree(&ds);
+	    if (!dh) {
+		Tcl_AppendResult(interp,
+		    "Could not read DH parameters from file", (char *) NULL);
+		SSL_CTX_free(ctx);
+		return (SSL_CTX *)0;
+	    }
+	} else {
+	    dh = get_dh2048();
+	}
+	SSL_CTX_set_tmp_dh(ctx, dh);
+	DH_free(dh);
+    }
+#endif
+
+    /* set our certificate */
+    if (cert != NULL) {
+	Tcl_DStringInit(&ds);
+
+	if (SSL_CTX_use_certificate_file(ctx, F2N( cert, &ds),
+					SSL_FILETYPE_PEM) <= 0) {
+	    Tcl_DStringFree(&ds);
+	    Tcl_AppendResult(interp,
+			     "unable to set certificate file ", cert, ": ",
+			     REASON(), (char *) NULL);
+	    SSL_CTX_free(ctx);
+	    return (SSL_CTX *)0;
+	}
+
+	/* get the private key associated with this certificate */
+	if (key == NULL) key=cert;
+
+	if (SSL_CTX_use_PrivateKey_file(ctx, F2N( key, &ds),
+					SSL_FILETYPE_PEM) <= 0) {
+	    Tcl_DStringFree(&ds);
+	    /* flush the passphrase which might be left in the result */
+	    Tcl_SetResult(interp, NULL, TCL_STATIC);
+	    Tcl_AppendResult(interp,
+			     "unable to set public key file ", key, " ",
+			     REASON(), (char *) NULL);
+	    SSL_CTX_free(ctx);
+	    return (SSL_CTX *)0;
+	}
+	Tcl_DStringFree(&ds);
+	/* Now we know that a key and cert have been set against
+	 * the SSL context */
+	if (!SSL_CTX_check_private_key(ctx)) {
+	    Tcl_AppendResult(interp,
+			     "private key does not match the certificate public key",
+			     (char *) NULL);
+	    SSL_CTX_free(ctx);
+	    return (SSL_CTX *)0;
+	}
+    } else {
+	cert = (char*)X509_get_default_cert_file();
+
+	if (SSL_CTX_use_certificate_file(ctx, cert,
+					SSL_FILETYPE_PEM) <= 0) {
+#if 0
+	    Tcl_DStringFree(&ds);
+	    Tcl_AppendResult(interp,
+			     "unable to use default certificate file ", cert, ": ",
+			     REASON(), (char *) NULL);
+	    SSL_CTX_free(ctx);
+	    return (SSL_CTX *)0;
+#endif
+	}
+    }
+	
+    Tcl_DStringInit(&ds);
+    Tcl_DStringInit(&ds1);
+    if (!SSL_CTX_load_verify_locations(ctx, F2N(CAfile, &ds), F2N(CAdir, &ds1)) ||
+	!SSL_CTX_set_default_verify_paths(ctx)) {
+#if 0
+	Tcl_DStringFree(&ds);
+	Tcl_DStringFree(&ds1);
+	/* Don't currently care if this fails */
+	Tcl_AppendResult(interp, "SSL default verify paths: ",
+		REASON(), (char *) NULL);
+	SSL_CTX_free(ctx);
+	return (SSL_CTX *)0;
+#endif
+    }
+
+    /* https://sourceforge.net/p/tls/bugs/57/ */
+    if ( CAfile != NULL ) {
+        STACK_OF(X509_NAME) *certNames = SSL_load_client_CA_file( F2N(CAfile, &ds) );
+	if ( certNames != NULL ) { 
+	    SSL_CTX_set_client_CA_list(ctx, certNames );
+	}
+    }
+
+    Tcl_DStringFree(&ds);
+    Tcl_DStringFree(&ds1);
+    return ctx;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * StatusObjCmd -- return certificate for connected peer.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+StatusObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj	*CONST objv[];
+{
+    State *statePtr;
+    X509 *peer;
+    Tcl_Obj *objPtr;
+    Tcl_Channel chan;
+    char *channelName, *ciphers;
+    int mode;
+
+    switch (objc) {
+	case 2:
+	    channelName = Tcl_GetStringFromObj(objv[1], NULL);
+	    break;
+
+	case 3:
+	    if (!strcmp (Tcl_GetString (objv[1]), "-local")) {
+		channelName = Tcl_GetStringFromObj(objv[2], NULL);
+		break;
+	    }
+	    /* else fall... */
+	default:
+	    Tcl_WrongNumArgs(interp, 1, objv, "?-local? channel");
+	    return TCL_ERROR;
+    }
+
+    chan = Tcl_GetChannel(interp, channelName, &mode);
+    if (chan == (Tcl_Channel) NULL) {
+	return TCL_ERROR;
+    }
+    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;
+    }
+    statePtr = (State *) Tcl_GetChannelInstanceData(chan);
+    if (objc == 2) {
+	peer = SSL_get_peer_certificate(statePtr->ssl);
+    } else {
+	peer = SSL_get_certificate(statePtr->ssl);
+    }
+    if (peer) {
+	objPtr = Tls_NewX509Obj(interp, peer);
+	if (objc == 2) { X509_free(peer); }
+    } else {
+	objPtr = Tcl_NewListObj(0, NULL);
+    }
+
+    Tcl_ListObjAppendElement (interp, objPtr,
+	    Tcl_NewStringObj ("sbits", -1));
+    Tcl_ListObjAppendElement (interp, objPtr,
+	    Tcl_NewIntObj (SSL_get_cipher_bits (statePtr->ssl, NULL)));
+
+    ciphers = (char*)SSL_get_cipher(statePtr->ssl);
+    if (ciphers != NULL && strcmp(ciphers, "(NONE)")!=0) {
+	Tcl_ListObjAppendElement(interp, objPtr,
+		Tcl_NewStringObj("cipher", -1));
+	Tcl_ListObjAppendElement(interp, objPtr,
+		Tcl_NewStringObj(SSL_get_cipher(statePtr->ssl), -1));
+    }
+    Tcl_SetObjResult( interp, objPtr);
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * VersionObjCmd -- return version string from OpenSSL.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+VersionObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj	*CONST objv[];
+{
+    Tcl_Obj *objPtr;
+
+    objPtr = Tcl_NewStringObj(OPENSSL_VERSION_TEXT, -1);
+
+    Tcl_SetObjResult(interp, objPtr);
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * MiscObjCmd -- misc commands
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *-------------------------------------------------------------------
+ */
+static int
+MiscObjCmd(clientData, interp, objc, objv)
+    ClientData clientData;	/* Not used. */
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj	*CONST objv[];
+{
+    static CONST84 char *commands [] = { "req", NULL };
+    enum command { C_REQ, C_DUMMY };
+    int cmd;
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?args?");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIndexFromObj(interp, objv[1], commands,
+	    "command", 0,&cmd) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    switch ((enum command) cmd) {
+	case C_REQ: {
+	    EVP_PKEY *pkey=NULL;
+	    X509 *cert=NULL;
+	    X509_NAME *name=NULL;
+	    Tcl_Obj **listv;
+	    int listc,i;
+
+	    BIO *out=NULL;
+
+	    char *k_C="",*k_ST="",*k_L="",*k_O="",*k_OU="",*k_CN="",*k_Email="";
+	    char *keyout,*pemout,*str;
+	    int keysize,serial=0,days=365;
+	    
+	    if ((objc<5) || (objc>6)) {
+		Tcl_WrongNumArgs(interp, 2, objv, "keysize keyfile certfile ?info?");
+		return TCL_ERROR;
+	    }
+
+	    if (Tcl_GetIntFromObj(interp, objv[2], &keysize) != TCL_OK) {
+		return TCL_ERROR;
+	    }
+	    keyout=Tcl_GetString(objv[3]);
+	    pemout=Tcl_GetString(objv[4]);
+
+	    if (objc>=6) {
+		if (Tcl_ListObjGetElements(interp, objv[5],
+			&listc, &listv) != TCL_OK) {
+		    return TCL_ERROR;
+		}
+
+		if ((listc%2) != 0) {
+		    Tcl_SetResult(interp,"Information list must have even number of arguments",NULL);
+		    return TCL_ERROR;
+		}
+		for (i=0; i<listc; i+=2) {
+		    str=Tcl_GetString(listv[i]);
+		    if (strcmp(str,"days")==0) {
+			if (Tcl_GetIntFromObj(interp,listv[i+1],&days)!=TCL_OK)
+			    return TCL_ERROR;
+		    } else if (strcmp(str,"serial")==0) {
+			if (Tcl_GetIntFromObj(interp,listv[i+1],&serial)!=TCL_OK)
+			    return TCL_ERROR;
+		    } else if (strcmp(str,"serial")==0) {
+			if (Tcl_GetIntFromObj(interp,listv[i+1],&serial)!=TCL_OK)
+			    return TCL_ERROR;
+		    } else if (strcmp(str,"C")==0) {
+			k_C=Tcl_GetString(listv[i+1]);
+		    } else if (strcmp(str,"ST")==0) {
+			k_ST=Tcl_GetString(listv[i+1]);
+		    } else if (strcmp(str,"L")==0) {
+			k_L=Tcl_GetString(listv[i+1]);
+		    } else if (strcmp(str,"O")==0) {
+			k_O=Tcl_GetString(listv[i+1]);
+		    } else if (strcmp(str,"OU")==0) {
+			k_OU=Tcl_GetString(listv[i+1]);
+		    } else if (strcmp(str,"CN")==0) {
+			k_CN=Tcl_GetString(listv[i+1]);
+		    } else if (strcmp(str,"Email")==0) {
+			k_Email=Tcl_GetString(listv[i+1]);
+		    } else {
+			Tcl_SetResult(interp,"Unknown parameter",NULL);
+			return TCL_ERROR;
+		    }
+		}
+	    }
+	    if ((pkey = EVP_PKEY_new()) != NULL) {
+		if (!EVP_PKEY_assign_RSA(pkey,
+			RSA_generate_key(keysize, 0x10001, NULL, NULL))) {
+		    Tcl_SetResult(interp,"Error generating private key",NULL);
+		    EVP_PKEY_free(pkey);
+		    return TCL_ERROR;
+		}
+		out=BIO_new(BIO_s_file());
+		BIO_write_filename(out,keyout);
+		PEM_write_bio_PrivateKey(out,pkey,NULL,NULL,0,NULL,NULL);
+		BIO_free_all(out);
+
+		if ((cert=X509_new())==NULL) {
+		    Tcl_SetResult(interp,"Error generating certificate request",NULL);
+		    EVP_PKEY_free(pkey);
+		    return(TCL_ERROR);
+		}
+
+		X509_set_version(cert,2);
+		ASN1_INTEGER_set(X509_get_serialNumber(cert),serial);
+		X509_gmtime_adj(X509_get_notBefore(cert),0);
+		X509_gmtime_adj(X509_get_notAfter(cert),(long)60*60*24*days);
+		X509_set_pubkey(cert,pkey);
+		
+		name=X509_get_subject_name(cert);
+
+		X509_NAME_add_entry_by_txt(name,"C", MBSTRING_ASC, k_C, -1, -1, 0);
+		X509_NAME_add_entry_by_txt(name,"ST", MBSTRING_ASC, k_ST, -1, -1, 0);
+		X509_NAME_add_entry_by_txt(name,"L", MBSTRING_ASC, k_L, -1, -1, 0);
+		X509_NAME_add_entry_by_txt(name,"O", MBSTRING_ASC, k_O, -1, -1, 0);
+		X509_NAME_add_entry_by_txt(name,"OU", MBSTRING_ASC, k_OU, -1, -1, 0);
+		X509_NAME_add_entry_by_txt(name,"CN", MBSTRING_ASC, k_CN, -1, -1, 0);
+		X509_NAME_add_entry_by_txt(name,"Email", MBSTRING_ASC, k_Email, -1, -1, 0);
+
+		X509_set_subject_name(cert,name);
+
+		if (!X509_sign(cert,pkey,EVP_md5())) {
+		    X509_free(cert);
+		    EVP_PKEY_free(pkey);
+		    Tcl_SetResult(interp,"Error signing certificate",NULL);
+		    return TCL_ERROR;
+		}
+
+		out=BIO_new(BIO_s_file());
+		BIO_write_filename(out,pemout);
+
+		PEM_write_bio_X509(out,cert);
+		BIO_free_all(out);
+
+		X509_free(cert);
+		EVP_PKEY_free(pkey);
+	    } else {
+		Tcl_SetResult(interp,"Error generating private key",NULL);
+		return TCL_ERROR;
+	    }
+	}
+	break;
+    default:
+	break;
+    }
+    return TCL_OK;
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Free --
+ *
+ *	This procedure cleans up when a SSL socket based channel
+ *	is closed and its reference count falls below 1
+ *
+ * Results:
+ *	none
+ *
+ * Side effects:
+ *	Frees all the state
+ *
+ *-------------------------------------------------------------------
+ */
+void
+Tls_Free( char *blockPtr )
+{
+    State *statePtr = (State *)blockPtr;
+
+    Tls_Clean(statePtr);
+    ckfree(blockPtr);
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Clean --
+ *
+ *	This procedure cleans up when a SSL socket based channel
+ *	is closed and its reference count falls below 1.  This should
+ *	be called synchronously by the CloseProc, not in the
+ *	EventuallyFree callback.
+ *
+ * Results:
+ *	none
+ *
+ * Side effects:
+ *	Frees all the state
+ *
+ *-------------------------------------------------------------------
+ */
+void
+Tls_Clean(State *statePtr)
+{
+    /*
+     * we're assuming here that we're single-threaded
+     */
+
+    if (statePtr->timer != (Tcl_TimerToken) NULL) {
+	Tcl_DeleteTimerHandler(statePtr->timer);
+	statePtr->timer = NULL;
+    }
+
+    if (statePtr->bio) {
+	/* This will call SSL_shutdown. Bug 1414045 */
+	dprintf(stderr, "BIO_free_all(%p)\n", statePtr->bio);
+	BIO_free_all(statePtr->bio);
+	statePtr->bio = NULL;
+    }
+    if (statePtr->ssl) {
+	dprintf(stderr, "SSL_free(%p)\n", statePtr->ssl);
+	SSL_free(statePtr->ssl);
+	statePtr->ssl = NULL;
+    }
+    if (statePtr->ctx) {
+	SSL_CTX_free(statePtr->ctx);
+	statePtr->ctx = NULL;
+    }
+    if (statePtr->callback) {
+	Tcl_DecrRefCount(statePtr->callback);
+	statePtr->callback = NULL;
+    }
+    if (statePtr->password) {
+	Tcl_DecrRefCount(statePtr->password);
+	statePtr->password = NULL;
+    }
+}
+
+/*
+ *-------------------------------------------------------------------
+ *
+ * Tls_Init --
+ *
+ *	This is a package initialization procedure, which is called
+ *	by Tcl when this package is to be added to an interpreter.
+ *
+ * Results:  Ssl configured and loaded
+ *
+ * Side effects:
+ *	 create the ssl command, initialise ssl context
+ *
+ *-------------------------------------------------------------------
+ */
+
+int
+Tls_Init(Tcl_Interp *interp)		/* Interpreter in which the package is
+					 * to be made available. */
+{
+    int major, minor, patchlevel, release;
+
+    /*
+     * 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+.  We only support 8.2+ now (8.3.2+ preferred).
+     */
+    if (
+#ifdef USE_TCL_STUBS
+	Tcl_InitStubs(interp, "8.2", 0)
+#else
+	Tcl_PkgRequire(interp, "Tcl", "8.2", 0)
+#endif
+	== NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * 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, &patchlevel, &release);
+    if ((major > 8) || ((major == 8) && ((minor > 3) || ((minor == 3) &&
+	    (release == TCL_FINAL_RELEASE) && (patchlevel >= 2))))) {
+	/* 8.3.2+ */
+	channelTypeVersion = TLS_CHANNEL_VERSION_2;
+    } else {
+	/* 8.2.0 - 8.3.1 */
+	channelTypeVersion = TLS_CHANNEL_VERSION_1;
+    }
+
+    if (TlsLibInit() != TCL_OK) {
+	Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
+	return TCL_ERROR;
+    }
+
+    Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    Tcl_CreateObjCommand(interp, "tls::misc", MiscObjCmd,
+	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+
+    return Tcl_PkgProvide(interp, PACKAGE_NAME, PACKAGE_VERSION);
+}
+
+/*
+ *------------------------------------------------------*
+ *
+ *	Tls_SafeInit --
+ *
+ *	------------------------------------------------*
+ *	Standard procedure required by 'load'. 
+ *	Initializes this extension for a safe interpreter.
+ *	------------------------------------------------*
+ *
+ *	Sideeffects:
+ *		As of 'Tls_Init'
+ *
+ *	Result:
+ *		A standard Tcl error code.
+ *
+ *------------------------------------------------------*
+ */
+
+int
+Tls_SafeInit (Tcl_Interp* interp)
+{
+    return Tls_Init (interp);
+}
+
+
+/*
+ *------------------------------------------------------*
+ *
+ *	TlsLibInit --
+ *
+ *	------------------------------------------------*
+ *	Initializes SSL library once per application
+ *	------------------------------------------------*
+ *
+ *	Side effects:
+ *		initilizes SSL library
+ *
+ *	Result:
+ *		none
+ *
+ *------------------------------------------------------*
+ */
+static int
+TlsLibInit ()
+{
+    int i;
+    char rnd_seed[16] = "GrzSlplKqUdnnzP!";	/* 16 bytes */
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+    size_t num_locks;
+#endif
+    int status=TCL_OK;
+
+    if (!initialized) {
+	Tcl_MutexLock(&init_mx);
+	if (!initialized) {
+	    initialized = 1;
+
+	    if (CRYPTO_set_mem_functions((void *(*)(size_t))Tcl_Alloc,
+					 (void *(*)(void *, size_t))Tcl_Realloc,
+					 (void(*)(void *))Tcl_Free) == 0) {
+	       /* Not using Tcl's mem functions ... not critical */
+	    }
+
+#if defined(OPENSSL_THREADS) && defined(TCL_THREADS)
+	    /* should we consider allocating mutexes? */
+	    num_locks = CRYPTO_num_locks();
+	    if (num_locks > CRYPTO_NUM_LOCKS) {
+		status=TCL_ERROR;
+		goto done;
+	    }
+
+	    CRYPTO_set_locking_callback(CryptoThreadLockCallback);
+	    CRYPTO_set_id_callback(CryptoThreadIdCallback);
+#endif
+
+	    if (SSL_library_init() != 1) {
+	    	status=TCL_ERROR;
+		goto done;
+	    }
+	    SSL_load_error_strings();
+	    ERR_load_crypto_strings();
+
+	    /*
+	     * Seed the random number generator in the SSL library,
+	     * using the do/while construct because of the bug note in the
+	     * OpenSSL FAQ at http://www.openssl.org/support/faq.html#USER1
+	     *
+	     * The crux of the problem is that Solaris 7 does not have a 
+	     * /dev/random or /dev/urandom device so it cannot gather enough
+	     * entropy from the RAND_seed() when TLS initializes and refuses
+	     * to go further. Earlier versions of OpenSSL carried on regardless.
+	     */
+	    srand((unsigned int) time((time_t *) NULL));
+	    do {
+		for (i = 0; i < 16; i++) {
+		    rnd_seed[i] = 1 + (char) (255.0 * rand()/(RAND_MAX+1.0));
+		}
+		RAND_seed(rnd_seed, sizeof(rnd_seed));
+	    } while (RAND_status() != 1);
+	}
+    	done:
+
+	Tcl_MutexUnlock(&init_mx);
+    }
+    return status;
+}