Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,19 @@ +2000-07-10 Jeff Hobbs + + * tlsBIO.c (BioWrite, BioRead): changed Tcl_Read/Write to + Tcl_ReadRaw/TclWriteRaw. + + * tls.c: added use of Tcl_GetTopChannel after Tcl_GetChannel and + got return value from Tcl_StackChannel. + + * tests/tlsIO.test: added some handshaking that shouldn't be + necessary, but we crash otherwise (needs more testing). + + * tlsIO.c: added support for "corrected" stacked channels. All + the above channels are in TCL_CHANNEL_VERSION_2 #ifdefs. + 2000-06-05 Scott Stanton * Makefile.in: Fixed broken test target. * tlsInt.h: Index: tests/tlsIO.test ================================================================== --- tests/tlsIO.test +++ tests/tlsIO.test @@ -8,11 +8,11 @@ # Copyright (c) 1998-2000 Ajuba Solutions. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tlsIO.test,v 1.14 2000/06/08 00:06:40 aborr Exp $ +# RCS: @(#) $Id: tlsIO.test,v 1.14.2.2 2000/07/12 01:54:03 hobbs Exp $ # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to @@ -311,14 +311,14 @@ package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]" puts $f { - proc accept {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file] $port" - close $file + puts "[gets $sock] $port" + close $sock set x done } puts ready vwait x after cancel $timer @@ -350,14 +350,14 @@ package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]" puts $f { - proc accept {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file] $addr" - close $file + puts "[gets $sock] $addr" + close $sock set x done } puts ready vwait x after cancel $timer @@ -387,14 +387,14 @@ package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]" puts $f { - proc accept {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file]" - close $file + puts "[gets $sock]" + close $sock set x done } puts ready vwait x after cancel $timer @@ -423,14 +423,14 @@ package require tls set timer [after 2000 "set x done"] } puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]" puts $f { - proc accept {file addr port} { + proc accept {sock addr port} { global x - puts "[gets $file]" - close $file + puts "[gets $sock]" + close $sock set x done } puts ready vwait x after cancel $timer Index: tls.c ================================================================== --- tls.c +++ tls.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-1999 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6 2000/06/06 01:34:11 welch Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6.2.1 2000/07/11 04:58:46 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 @@ -538,10 +538,16 @@ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); +#endif if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), "\": not a TLS channel", NULL); return TCL_ERROR; } @@ -630,10 +636,16 @@ chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL); if (chan == (Tcl_Channel) NULL) { return TCL_ERROR; } +#ifdef TCL_CHANNEL_VERSION_2 + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); +#endif for (idx = 2; idx < objc; idx++) { char *opt = Tcl_GetStringFromObj(objv[idx], NULL); if (opt[0] != '-') @@ -678,10 +690,16 @@ /* Get the "model" context */ chan = Tcl_GetChannel( interp, model, &mode); if (chan == (Tcl_Channel)0) { 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; } @@ -721,13 +739,18 @@ statePtr->parent = chan; statePtr->self = Tcl_ReplaceChannel( interp, Tls_ChannelType(), (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), statePtr->parent); #else +#ifdef TCL_CHANNEL_VERSION_2 + statePtr->self = Tcl_StackChannel(interp, Tls_ChannelType(), + (ClientData) statePtr, (TCL_READABLE | TCL_WRITABLE), chan); +#else statePtr->self = chan; Tcl_StackChannel( interp, Tls_ChannelType(), (ClientData) statePtr, - (TCL_READABLE | TCL_WRITABLE), chan); + (TCL_READABLE | TCL_WRITABLE), chan); +#endif #endif if (statePtr->self == (Tcl_Channel) NULL) { /* * No use of Tcl_EventuallyFree because no possible Tcl_Preserve. */ @@ -988,10 +1011,16 @@ chan = Tcl_GetChannel( interp, channelName, &mode); if (chan == (Tcl_Channel)0) { 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; } Index: tlsBIO.c ================================================================== --- tlsBIO.c +++ tlsBIO.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2 2000/01/20 01:51:39 aborr Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.1 2000/07/11 04:58:46 hobbs Exp $ * * Provides BIO layer to interface openssl to Tcl. */ #include "tlsInt.h" @@ -61,11 +61,15 @@ Tcl_Channel chan = Tls_GetParent((State*)bio->ptr); int ret; dprintf(stderr,"\nBioWrite(0x%x, , %d) [0x%x]", bio, bufLen, chan); +#ifdef TCL_CHANNEL_VERSION_2 + ret = Tcl_WriteRaw( chan, buf, bufLen); +#else ret = Tcl_Write( chan, buf, bufLen); +#endif dprintf(stderr,"\n[0x%x] BioWrite(%d) -> %d [%d.%d]", chan, bufLen, ret, Tcl_Eof( chan), Tcl_GetErrno()); BIO_clear_flags(bio, BIO_FLAGS_WRITE|BIO_FLAGS_SHOULD_RETRY); @@ -92,11 +96,15 @@ dprintf(stderr,"\nBioRead(0x%x, , %d) [0x%x]", bio, bufLen, chan); if (buf == NULL) return 0; +#ifdef TCL_CHANNEL_VERSION_2 + ret = Tcl_ReadRaw( chan, buf, bufLen); +#else ret = Tcl_Read( chan, buf, bufLen); +#endif dprintf(stderr,"\n[0x%x] BioRead(%d) -> %d [%d.%d]", chan, bufLen, ret, Tcl_Eof(chan), Tcl_GetErrno()); BIO_clear_flags(bio, BIO_FLAGS_READ|BIO_FLAGS_SHOULD_RETRY); Index: tlsIO.c ================================================================== --- tlsIO.c +++ tlsIO.c @@ -1,9 +1,9 @@ /* * Copyright (C) 1997-2000 Matt Newman * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7 2000/06/05 18:09:54 welch Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.1 2000/07/11 04:58:46 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 @@ -48,11 +48,28 @@ /* * This structure describes the channel type structure for TCP socket * based IO: */ - +#ifdef TCL_CHANNEL_VERSION_2 +static Tcl_ChannelType tlsChannelType = { + "tls", /* Type name. */ + TCL_CHANNEL_VERSION_2, /* A NG channel */ + CloseProc, /* Close proc. */ + InputProc, /* Input proc. */ + OutputProc, /* Output proc. */ + NULL, /* Seek proc. */ + NULL, /* Set option proc. */ + GetOptionProc, /* Get option proc. */ + WatchProc, /* Initialize notifier. */ + GetHandleProc, /* Get file handle out of channel. */ + NULL, /* Close2Proc. */ + BlockModeProc, /* Set blocking/nonblocking mode.*/ + NULL, /* FlushProc. */ + NULL, /* handlerProc. */ +}; +#else static Tcl_ChannelType tlsChannelType = { "tls", /* Type name. */ BlockModeProc, /* Set blocking/nonblocking mode.*/ CloseProc, /* Close proc. */ InputProc, /* Input proc. */ @@ -61,10 +78,11 @@ NULL, /* Set option proc. */ GetOptionProc, /* Get option proc. */ WatchProc, /* Initialize notifier. */ GetHandleProc, /* Get file handle out of channel. */ }; +#endif Tcl_ChannelType *Tls_ChannelType() { return &tlsChannelType; } @@ -96,12 +114,16 @@ if (mode == TCL_MODE_NONBLOCKING) { statePtr->flags |= TLS_TCL_ASYNC; } else { statePtr->flags &= ~(TLS_TCL_ASYNC); } +#ifdef TCL_CHANNEL_VERSION_2 + return 0; +#else return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr), "-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1"); +#endif } /* *------------------------------------------------------------------- * @@ -335,10 +357,30 @@ * NULL to get all options and * their values. */ Tcl_DString *dsPtr) /* Where to store the computed value * initialized by caller. */ { +#ifdef TCL_CHANNEL_VERSION_2 + State *statePtr = (State *) instanceData; + Tcl_Channel downChan = Tls_GetParent(statePtr); + Tcl_DriverGetOptionProc *getOptionProc; + + getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); + if (getOptionProc != NULL) { + return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), + interp, optionName, dsPtr); + } else if (optionName == (char*) NULL) { + /* + * Request is query for all options, this is ok. + */ + return TCL_OK; + } + /* + * Request for a specific option has to fail, we don't have any. + */ + return TCL_ERROR; +#else State *statePtr = (State *) instanceData; size_t len = 0; if (optionName != (char *) NULL) { len = strlen(optionName); @@ -355,10 +397,11 @@ return TCL_OK; } } #endif return TCL_OK; +#endif } /* *------------------------------------------------------------------- * @@ -622,10 +665,13 @@ Tcl_Channel Tls_GetParent( statePtr ) State *statePtr; { +#ifdef TCL_CHANNEL_VERSION_2 + return Tcl_GetStackedChannel(statePtr->self); +#else #if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2 return statePtr->parent; #else /* The reason for the existence of this procedure is * the fact that stacking a transform over another @@ -640,29 +686,31 @@ * It walks the chain of Channel structures until it * finds the one pointing having 'ctrl' as instanceData * and then returns the superceding channel to that. (AK) */ - Tcl_Channel self = statePtr->self; - Tcl_Channel next; - - while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { - next = Tcl_GetStackedChannel (self); - if (next == (Tcl_Channel) NULL) { - /* 09/24/1999 Unstacking bug, found by Matt Newman . - * - * We were unable to find the channel structure for this - * transformation in the chain of stacked channel. This - * means that we are currently in the process of unstacking - * it *and* there were some bytes waiting which are now - * flushed. In this situation the pointer to the channel - * itself already refers to the parent channel we have to - * write the bytes into, so we return that. - */ - return statePtr->self; - } - self = next; - } - - return Tcl_GetStackedChannel (self); + Tcl_Channel self = statePtr->self; + Tcl_Channel next; + + while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) { + next = Tcl_GetStackedChannel (self); + if (next == (Tcl_Channel) NULL) { + /* 09/24/1999 Unstacking bug, + * found by Matt Newman . + * + * We were unable to find the channel structure for this + * transformation in the chain of stacked channel. This + * means that we are currently in the process of unstacking + * it *and* there were some bytes waiting which are now + * flushed. In this situation the pointer to the channel + * itself already refers to the parent channel we have to + * write the bytes into, so we return that. + */ + return statePtr->self; + } + self = next; + } + + return Tcl_GetStackedChannel (self); +#endif #endif }