2000-07-26  Jeff Hobbs  <[email protected]>

	* tls.c (ImportObjCmd): removed unnecessary use of 'bio' arg.
	(Tls_Init): check return value of SSL_library_init.  Also lots of
	whitespace cleanup (more like Tcl Eng style guide), but not all
	code was cleaned up.

	* tlsBIO.c: minor whitespace cleanup

	* tlsIO.c: minor whitespace cleanup.
	(TlsInputProc, TlsOutputProc): Added ERR_clear_error before calls
	to BIO_read or BIO_write, because we could otherwise end up
	pulling an error off the stack that didn't belong to us.  Also
	cleanup up excessive use of gotos.

2000-07-20  Jeff Hobbs  <[email protected]>

	* tests/tlsIO.test: corrected various tests to be correct for TLS
	stacked channels (as opposed to the standard sockets the test
	suite was adopted from).  Key differences are that TLS cannot
	operate in one process without all channels being non-blocking, or
	the handshake will block, and handshaking must be forced in some

/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.2 2000/07/21 05:32:56 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.3 2000/07/26 22:15:07 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
 * OpenSSL 0.9.2B
 *

 *	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;
    char *errStr;
    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);
    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);
    Tcl_Obj *cmdPtr;
    int depth = X509_STORE_CTX_get_error_depth(ctx);
    int err = X509_STORE_CTX_get_error(ctx);
    int depth		= X509_STORE_CTX_get_error_depth(ctx);
    int err		= X509_STORE_CTX_get_error(ctx);
    char *errStr;

    dprintf(stderr, "Verify: %d\n", ok);

    if (!ok)
    if (!ok) {
	errStr = (char*)X509_verify_cert_error_string(err);
    else
    } else {
	errStr = (char *)0;

    }

    if (statePtr->callback == (Tcl_Obj*)NULL) {
	if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT)
	if (statePtr->vflags & SSL_VERIFY_FAIL_IF_NO_PEER_CERT) {
	    return ok;
	else
	} else {
	    return 1;
	}
    }
    cmdPtr = Tcl_DuplicateObj(statePtr->callback);

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj( "verify", -1));

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 

 */
void
Tls_Error(State *statePtr, char *msg)
{
    Tcl_Obj *cmdPtr;

    if (msg && *msg) {
	Tcl_SetErrorCode( statePtr->interp, "SSL", msg, (char *)NULL);
	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("error", -1));

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj( Tcl_GetChannelName(statePtr->self), -1) );
    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr, 
	    Tcl_NewStringObj(Tcl_GetChannelName(statePtr->self), -1));

    Tcl_ListObjAppendElement( statePtr->interp, cmdPtr,
	    Tcl_NewStringObj( msg, -1) );
    Tcl_ListObjAppendElement(statePtr->interp, cmdPtr,
	    Tcl_NewStringObj(msg, -1));

    Tcl_Preserve( (ClientData) statePtr->interp);
    Tcl_Preserve( (ClientData) statePtr);
    Tcl_Preserve((ClientData) statePtr->interp);
    Tcl_Preserve((ClientData) statePtr);

    Tcl_IncrRefCount( cmdPtr);
    Tcl_IncrRefCount(cmdPtr);
    if (Tcl_GlobalEvalObj(statePtr->interp, cmdPtr) != TCL_OK) {
	Tcl_BackgroundError( statePtr->interp);
	Tcl_BackgroundError(statePtr->interp);
    }
    Tcl_DecrRefCount( cmdPtr);
    Tcl_DecrRefCount(cmdPtr);

    Tcl_Release( (ClientData) statePtr);
    Tcl_Release( (ClientData) statePtr->interp);
    Tcl_Release((ClientData) statePtr);
    Tcl_Release((ClientData) statePtr->interp);
}

/*
 *-------------------------------------------------------------------
 *
 * PasswordCallback -- 
 *

		Tcl_AppendResult(interp, "protocol not supported", NULL);
		return TCL_ERROR;
#else
		ctx = SSL_CTX_new(TLSv1_method()); break;
#endif
    }
    if (ctx == NULL) {
	Tcl_AppendResult(interp, REASON(),
	Tcl_AppendResult(interp, REASON(), (char *) NULL);
	    (char *) NULL);
	return TCL_ERROR;
    }
    ssl = SSL_new(ctx);
    if (ssl == NULL) {
	Tcl_AppendResult(interp, REASON(),
	Tcl_AppendResult(interp, REASON(), (char *) NULL);
	    (char *) NULL);
	SSL_CTX_free(ctx);
	return TCL_ERROR;
    }
    objPtr = Tcl_NewListObj( 0, NULL);

    if (!verbose) {
	for (index = 0; ; index++) {

	    }

	    Tcl_AppendResult(interp, "handshake failed: ", errStr,
		    (char *) NULL);
	    return TCL_ERROR;
	}
    }

    Tcl_SetObjResult(interp, Tcl_NewIntObj(ret));
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *

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. */
    BIO *bio;
    State *statePtr;		/* client state for ssl socket */
    SSL_CTX *ctx = NULL;
    Tcl_Obj *script = NULL;
    SSL_CTX *ctx	= NULL;
    Tcl_Obj *script	= NULL;
    int idx;
    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 *model = NULL;
    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 *model		= NULL;
#if defined(NO_SSL2)
    int ssl2 = 0;
#else
    int ssl2 = 1;
#endif
#if defined(NO_SSL3)
    int ssl3 = 0;

	OPTBOOL( "-ssl3", ssl3);
	OPTBOOL( "-tls1", tls1);

	OPTBAD( "option", "-cafile, -cadir, -certfile, -cipher, -command, -keyfile, -model, -require, -request, -ssl2, -ssl3, -server, or -tls1");

	return TCL_ERROR;
    }
    if (request) verify |= SSL_VERIFY_CLIENT_ONCE | SSL_VERIFY_PEER;
    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;
    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);

    /* 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 (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 (model != NULL) {
	int mode;
	/* Get the "model" context */
	chan = Tcl_GetChannel( interp, model, &mode);
	if (chan == (Tcl_Channel)0) {
	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 (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
	    Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
		    "\": not a TLS channel", NULL);
	    Tcl_AppendResult(interp, "bad channel \"",
		    Tcl_GetChannelName(chan), "\": not a TLS channel", NULL);
	    return TCL_ERROR;
	}
	statePtr = (State *)Tcl_GetChannelInstanceData( chan);
	statePtr = (State *) Tcl_GetChannelInstanceData(chan);
	ctx = statePtr->ctx;
    } else {
	if ((ctx = CTX_Init( interp, proto, key, cert, CAdir, CAfile, ciphers))
	if ((ctx = CTX_Init(interp, proto, key, cert, CAdir, CAfile, ciphers))
	    == (SSL_CTX*)0) {
	    return TCL_ERROR;
	}
    }

    /* new SSL state */
    statePtr = (State *) Tcl_Alloc((unsigned) sizeof(State));
    statePtr->self = (Tcl_Channel)NULL;
    statePtr->timer = (Tcl_TimerToken)NULL;
    statePtr		= (State *) Tcl_Alloc((unsigned) sizeof(State));
    statePtr->self	= (Tcl_Channel)NULL;
    statePtr->timer	= (Tcl_TimerToken)NULL;

    statePtr->flags = flags;
    statePtr->watchMask = 0;
    statePtr->mode = 0;
    statePtr->flags	= flags;
    statePtr->watchMask	= 0;
    statePtr->mode	= 0;

    statePtr->interp = interp;
    statePtr->callback = (Tcl_Obj *)0;
    statePtr->interp	= interp;
    statePtr->callback	= (Tcl_Obj *)0;

    statePtr->vflags = verify;
    statePtr->ssl = (SSL*)0;
    statePtr->ctx = ctx;
    statePtr->bio = (BIO*)0;
    statePtr->p_bio = (BIO*)0;
    statePtr->vflags	= verify;
    statePtr->ssl	= (SSL*)0;
    statePtr->ctx	= ctx;
    statePtr->bio	= (BIO*)0;
    statePtr->p_bio	= (BIO*)0;

    statePtr->err = "";
    statePtr->err	= "";

    /*
     * 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");
#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);
    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 (statePtr->self == (Tcl_Channel) NULL) {
	/*
	 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
	 */
	Tls_Free((char *) statePtr);
        return TCL_ERROR;
    }

    /* allocate script */
    if (script) {
	char * tmp = Tcl_GetStringFromObj(script, NULL);
	char *tmp = Tcl_GetStringFromObj(script, NULL);
	if (tmp && *tmp) {
	    statePtr->callback = Tcl_DuplicateObj(script);
	    Tcl_IncrRefCount( statePtr->callback);
	    Tcl_IncrRefCount(statePtr->callback);
	}
    }
    /* This is only needed because of a bug in OpenSSL, where the
     * ssl->verify_callback is not referenced!!! (Must be done
     * *before* SSL_new() is called!
     */
    SSL_CTX_set_verify(statePtr->ctx, verify, VerifyCallback);

    /*
     * 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);
        Tcl_AppendResult(interp, "couldn't construct ssl session: ", REASON(),
		(char *) NULL);
	Tls_Free((char *) statePtr);
        return TCL_ERROR;
    }

    /*
     * SSL Callbacks
     */

    SSL_set_app_data(statePtr->ssl, (VOID *)statePtr);	/* point back to us */

    /*
     * The following is broken - we need is to set the
     * verify_mode, but the library ignores the verify_callback!!!
     */
    /*SSL_set_verify(statePtr->ssl, verify, VerifyCallback);*/

    SSL_CTX_set_info_callback( statePtr->ctx, InfoCallback);
    SSL_CTX_set_info_callback(statePtr->ctx, InfoCallback);

    /* Create Tcl_Channel BIO Handler */
    statePtr->p_bio = bio = BIO_new_tcl( statePtr, BIO_CLOSE);
    statePtr->bio = BIO_new(BIO_f_ssl());
    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, bio, bio);
    SSL_set_bio(statePtr->ssl, statePtr->p_bio, statePtr->p_bio);
    BIO_set_ssl(statePtr->bio, statePtr->ssl, BIO_CLOSE);

    /*
     * End of SSL Init
     */
    Tcl_SetResult(interp, Tcl_GetChannelName(statePtr->self), TCL_VOLATILE);
    return TCL_OK;

    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);
		REASON(), (char *) NULL);
	SSL_CTX_free(ctx);
	return (SSL_CTX *)0;
#endif
    }
    SSL_CTX_set_client_CA_list(ctx, SSL_load_client_CA_file( F2N(CAfile, &ds) ));

    Tcl_DStringFree(&ds);

    if (objc != 2) {
        Tcl_WrongNumArgs(interp, 1, objv, "channel");
        return TCL_ERROR;
    }
    channelName = Tcl_GetStringFromObj(objv[1], NULL);

    chan = Tcl_GetChannel( interp, channelName, &mode);
    if (chan == (Tcl_Channel)0) {
    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 (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);
    peer = SSL_get_peer_certificate(statePtr->ssl);
    if (peer)
	objPtr = Tls_NewX509Obj( interp, peer);
    else
	objPtr = Tcl_NewListObj( 0, NULL);
    statePtr	= (State *) Tcl_GetChannelInstanceData(chan);
    peer	= SSL_get_peer_certificate(statePtr->ssl);
    if (peer) {
	objPtr = Tls_NewX509Obj(interp, peer);
    } else {
	objPtr = Tcl_NewListObj(0, 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_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;
}

/*
 *-------------------------------------------------------------------

                                         * to be made available. */
{
#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 2
    if (!Tcl_InitStubs(interp, TCL_VERSION, 0)) {
        return TCL_ERROR;
    }
#endif
    if (SSL_library_init() != 1) {
        Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
	return TCL_ERROR;
    }
    SSL_load_error_strings();
    ERR_load_crypto_strings();
    SSL_library_init();

    Tcl_CreateObjCommand(interp, "tls::ciphers", CiphersObjCmd , (ClientData) 0,
                      (Tcl_CmdDeleteProc *) NULL);
    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::handshake", HandshakeObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd , (ClientData) 0,
                      (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd , (ClientData) 0,
                      (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

    return Tcl_PkgProvide(interp, PACKAGE, VERSION);
}


/*
 *------------------------------------------------------*
 *
 *	Tls_SafeInit --
 *
 *	------------------------------------------------*

/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.3 2000/07/21 05:32:57 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.4 2000/07/26 22:15:07 hobbs Exp $
 *
 * Provides BIO layer to interface openssl to Tcl.
 */

#include "tlsInt.h"

/*

BIO *
BIO_new_tcl(statePtr, flags)
    State *statePtr;
    int flags;
{
    BIO *bio;

    bio = BIO_new(&BioMethods);
    bio->ptr = (char*)statePtr;
    bio->init = 1;
    bio->shutdown = flags;
    bio			= BIO_new(&BioMethods);
    bio->ptr		= (char*)statePtr;
    bio->init		= 1;
    bio->shutdown	= flags;

    return bio;
}

BIO_METHOD *
BIO_s_tcl()
{
    return &BioMethods;
}

static int
BioWrite (bio, buf, bufLen)
    BIO *bio;
    char *buf;
    int bufLen;
{
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    Tcl_Channel chan = Tls_GetParent((State*)(bio->ptr));
    int ret;

    dprintf(stderr,"\nBioWrite(0x%x, <buf>, %d) [0x%x]", bio, bufLen, chan);

#ifdef TCL_CHANNEL_VERSION_2
    ret = Tcl_WriteRaw( chan, buf, bufLen);
    ret = Tcl_WriteRaw(chan, buf, bufLen);
#else
    ret = Tcl_Write( chan, buf, bufLen);
    ret = Tcl_Write(chan, buf, bufLen);
#endif

    dprintf(stderr,"\n[0x%x] BioWrite(%d) -> %d [%d.%d]", chan, bufLen, ret,
		Tcl_Eof( chan), Tcl_GetErrno());
	    Tcl_Eof(chan), Tcl_GetErrno());

    BIO_clear_flags(bio, BIO_FLAGS_WRITE|BIO_FLAGS_SHOULD_RETRY);

    if (ret == 0) {
	if (!Tcl_Eof( chan)) {
	if (!Tcl_Eof(chan)) {
	    BIO_set_retry_write(bio);
	    ret = -1;
	}
    }
    if (BIO_should_read(bio))
    if (BIO_should_read(bio)) {
	BIO_set_retry_read(bio);
    }
    return ret;
}

static int
BioRead (bio, buf, bufLen)
    BIO *bio;
    char *buf;
    int bufLen;
{
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    int ret = 0;

    dprintf(stderr,"\nBioRead(0x%x, <buf>, %d) [0x%x]", bio, bufLen, chan);

    if (buf == NULL) return 0;

#ifdef TCL_CHANNEL_VERSION_2
    ret = Tcl_ReadRaw( chan, buf, bufLen);
    ret = Tcl_ReadRaw(chan, buf, bufLen);
#else
    ret = Tcl_Read( chan, buf, bufLen);
    ret = Tcl_Read(chan, buf, bufLen);
#endif

    dprintf(stderr,"\n[0x%x] BioRead(%d) -> %d [%d.%d]", chan, bufLen, ret,
	Tcl_Eof(chan), Tcl_GetErrno());
	    Tcl_Eof(chan), Tcl_GetErrno());

    BIO_clear_flags(bio, BIO_FLAGS_READ|BIO_FLAGS_SHOULD_RETRY);

    if (ret == 0) {
	if (!Tcl_Eof( chan)) {
	if (!Tcl_Eof(chan)) {
	    BIO_set_retry_read(bio);
	    ret = -1;
	}
    }
    if (BIO_should_write(bio))
    if (BIO_should_write(bio)) {
	BIO_set_retry_write(bio);
    }
    return ret;
}

static int
BioPuts	(bio, str)
    BIO *bio;
    char *str;
{
    return BioWrite( bio, str, strlen(str));
    return BioWrite(bio, str, strlen(str));
}

static long
BioCtrl	(bio, cmd, num, ptr)
    BIO *bio;
    int cmd;
    long num;

	ret = bio->shutdown;
	break;
    case BIO_CTRL_SET_CLOSE:
	bio->shutdown = (int)num;
	break;
    case BIO_CTRL_EOF:
	dprintf(stderr, "BIO_CTRL_EOF\n");
	ret = Tcl_Eof( chan);
	ret = Tcl_Eof(chan);
	break;
    case BIO_CTRL_PENDING:
	ret = (Tcl_InputBuffered(chan) ? 1 : 0);
	dprintf(stderr, "BIO_CTRL_PENDING(%d)\n", ret);
	break;
    case BIO_CTRL_WPENDING:
	ret = 0;
	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
	    Tcl_Flush(chan) == TCL_OK
#endif
	    ) {
	    ret = 1;
	} else {
	    ret = -1;
	}
	break;

/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.3 2000/07/21 05:32:57 hobbs Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.4 2000/07/26 22:15:07 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
 *
 * Addition credit is due for Andreas Kupries ([email protected]), for

     */

    Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
	TlsChannelHandler, (ClientData) statePtr);
#endif

    Tls_Clean(statePtr);
    Tcl_EventuallyFree( (ClientData)statePtr, Tls_Free);
    Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * TlsInputProc --

 *	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. */
	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 (!SSL_is_init_finished(statePtr->ssl)) {
	bytesRead = Tls_WaitForConnect(statePtr, errorCodePtr);
	if (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;
	    goto input;
	} else if (BIO_should_retry(statePtr->bio)) {
	    dprintf(stderr,"RE! ");
	    *errorCodePtr = EAGAIN;
	    goto input;
	}
	if (Tcl_GetErrno() == ECONNRESET) {
	    /* Soft EOF */
	    bytesRead = 0;
	} else {
	    *errorCodePtr = Tcl_GetErrno();
	    if (*errorCodePtr == ECONNRESET) {
		/* Soft EOF */
		*errorCodePtr = 0;
		bytesRead = 0;
	    goto input;
	} else {
	    *errorCodePtr = Tcl_GetErrno();
	    goto input;
	}
    }
input:
	    }
	}
    }
    input:
    dprintf(stderr, "\nInput(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
    return bytesRead;
}

/*
 *-------------------------------------------------------------------
 *

 *	Writes output on the output device of the channel.
 *
 *-------------------------------------------------------------------
 */

static int
TlsOutputProc(ClientData instanceData,	/* Socket state. */
              char *buf,			/* The data buffer. */
              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(%d)", toWrite);
    dprintf(stderr,"\nBIO_write(0x%x, %d)", statePtr, toWrite);

    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(%d) -> [%d]", toWrite, written);
	dprintf(stderr,"\nBIO_write(0x%x, %d) -> [%d]",
		statePtr, toWrite, written);
    }
    if (written < 0 || written == 0) {
    if (written <= 0) {
	switch ((err = SSL_get_error(statePtr->ssl, written))) {
	case SSL_ERROR_NONE:
	    if (written <= 0) {
		written = 0;
	    case SSL_ERROR_NONE:
		if (written < 0) {
		    written = 0;
		goto output;
	    }
	    break;
	case SSL_ERROR_WANT_WRITE:
	    dprintf(stderr,"write W BLOCK\n");
	    break;
	case SSL_ERROR_WANT_READ:
	    dprintf(stderr,"write R BLOCK\n");
	    break;
	case SSL_ERROR_WANT_X509_LOOKUP:
	    dprintf(stderr,"write X BLOCK\n");
	    break;
	case SSL_ERROR_ZERO_RETURN:
	    dprintf(stderr,"closed\n");
	    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;
	    goto output;
	case SSL_ERROR_SYSCALL:
	    *errorCodePtr = Tcl_GetErrno();
	    dprintf(stderr,"[%d] syscall errr: %d\n", written, Tcl_GetErrno());
	    written = -1;
		break;
	    case SSL_ERROR_SYSCALL:
		*errorCodePtr = Tcl_GetErrno();
		dprintf(stderr," [%d] syscall errr: %d",
			written, *errorCodePtr);
		written = -1;
	    goto output;
	case SSL_ERROR_SSL:
	    Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written));
	    *errorCodePtr = ECONNABORTED;
	    written = -1;
		break;
	    case SSL_ERROR_SSL:
		Tls_Error(statePtr, SSL_ERROR(statePtr->ssl, written));
		*errorCodePtr = ECONNABORTED;
		written = -1;
	    goto output;
	default:
	    dprintf(stderr,"unknown err: %d\n", err);
		break;
	    default:
		dprintf(stderr," unknown err: %d\n", err);
		break;
	}
    }
output:
    output:
    dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written);
    return written;
}

/*
 *-------------------------------------------------------------------
 *