Index: ChangeLog ================================================================== --- ChangeLog +++ ChangeLog @@ -1,5 +1,41 @@ +2000-07-13 Jeff Hobbs + + * tests/tlsIO.test: enabled tests 2.10, 7.[1245] (there is no 3), + which now pass. Added some comments to other failing tests. + +2000-07-11 Jeff Hobbs + + * tlsIO.c: changed all the channel procs to start with Tls* for + better parity when comparing with Transform channel procs. + Rewrote TlsWatchProc, added TlsNotifyProc according to the new + channel design, which also leaves TlsChannelHandler unused. + + * tlsBIO.c (BioCtrl): changed BIO_CTRL_FLUSH case to use + Tcl_WriteRaw instead of Tcl_Flush (to operate on correct channel + in the stack instead of starting at the top again). Would + otherwise cause a recursive stack bomb when implicit handshaking + took effect. + + * tests/tlsIO.test: removed changes made to test suite (all tests + that ran before now pass correctly), and changed some accept proc + args to reflect that a sock is an arg, not a file. + +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.3 2000/07/14 04:10:23 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 @@ -576,11 +576,11 @@ (procedure "tls::socket" line 62) invoked from within "tls::socket -server accept 8828" (file "script" line 1)}} -test tlsIO-2.10 {close on accept, accepted socket lives} {socket knownBug} { +test tlsIO-2.10 {close on accept, accepted socket lives} {socket} { set done 0 set timer [after 20000 "set done timed_out"] set ss [tls::socket -server accept -certfile $serverCert -cafile $caCert \ -keyfile $serverKey 8830] proc accept {s a p} { @@ -603,10 +603,11 @@ after cancel $timer set done } 1 test tlsIO-2.11 {detecting new data} {socket knownBug} { + # HOBBS: hung pre-rewrite, hangs post-rewrite proc accept {s a p} { global sock set sock $s set f [open awb.log w] puts $f [catch {tls::handshake $sock} err] @@ -866,10 +867,11 @@ } set x } {couldn't open socket: not owner} test tlsIO-6.1 {accept callback error} {unexplainedFailure socket stdio pcCrash} { + # HOBBS: still fails post-rewrite removeFile script set f [open script w] puts $f { package require tls gets stdin @@ -893,11 +895,11 @@ set x } {{divide by zero}} # bug report #5812 fconfigure doesn't return value for '-peername' -test tlsIO-7.1 {testing socket specific options} {knownBug socket stdio} { +test tlsIO-7.1 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { package require tls } @@ -927,11 +929,11 @@ lappend l [llength $p] } {0 0 3} # bug report #5812 fconfigure doesn't return value for '-sockname' -test tlsIO-7.2 {testing socket specific options} {knownBug socket stdio} { +test tlsIO-7.2 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { package require tls } @@ -971,11 +973,11 @@ llength $l } 12 # bug report #5812 fconfigure doesn't return value for '-sockname' -test tlsIO-7.4 {testing socket specific options} {knownBug socket} { +test tlsIO-7.4 {testing socket specific options} {socket} { set s [tls::socket \ -certfile $serverCert -cafile $caCert -keyfile $serverKey \ -server accept 8823] proc accept {s a p} { global x @@ -994,11 +996,11 @@ lappend l [lindex $x 2] [llength $x] } {8823 3} # bug report #5812 fconfigure doesn't return value for '-sockname' -test tlsIO-7.5 {testing socket specific options} {knownBug socket unixOrPc} { +test tlsIO-7.5 {testing socket specific options} {socket unixOrPc} { set s [tls::socket \ -certfile $serverCert -cafile $caCert -keyfile $serverKey \ -server accept 8829] proc accept {s a p} { global x @@ -1016,10 +1018,11 @@ set l "" lappend l [lindex $x 0] [lindex $x 2] [llength $x] } {127.0.0.1 8829 3} test tlsIO-8.1 {testing -async flag on sockets} {unexplainedHang socket} { + # HOBBS: still fails post-rewrite # test seems to hang -- awb 6/2/2000 # NOTE: This test may fail on some Solaris 2.4 systems. If it does, # check that you have these patches installed (using showrev -p): # # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03, @@ -1051,10 +1054,11 @@ close $s1 set z } bye test tlsIO-9.1 {testing spurious events} {unexplainedHang socket} { + # HOBBS: still fails post-rewrite # locks up set len 0 set spurious 0 set done 0 proc readlittle {s} { @@ -1089,10 +1093,12 @@ close $s list $spurious $len } {0 50} test tlsIO-9.2 {testing async write, fileevents, flush on close} {socket} { + # HOBBS: This hangs when I turn blocking on. + # set firstblock "" for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"} set secondblock "" for {set i 0} {$i < 16} {incr i} { set secondblock "b$secondblock$secondblock" @@ -1134,18 +1140,20 @@ close $s set done 1 } } fileevent $s readable "readit $s" + set done 0 set timer [after 10000 "set done timed_out"] vwait done after cancel $timer close $l - set count -} 65566 + list $count $done +} {65566 1} test tlsIO-9.3 {testing EOF stickyness} {unexplainedHang socket} { + # HOBBS: still fails post-rewrite # hangs proc count_to_eof {s} { global count done timer set l [gets $s] if {[eof $s]} { 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.2 2000/07/12 01:54:26 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); @@ -181,17 +189,24 @@ break; case BIO_CTRL_DUP: break; case BIO_CTRL_FLUSH: dprintf(stderr, "BIO_CTRL_FLUSH\n"); - if (Tcl_Flush( chan) == TCL_OK) - ret=1; - else - ret=-1; + if ( +#ifdef TCL_CHANNEL_VERSION_2 + Tcl_WriteRaw(chan, "", 0) >= 0 +#else + Tcl_Flush( chan) == TCL_OK +#endif + ) { + ret = 1; + } else { + ret = -1; + } break; default: - ret=0; + ret = 0; break; } return(ret); } 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.2 2000/07/12 01:54:26 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 @@ -30,51 +30,75 @@ /* * Forward declarations */ -static int BlockModeProc _ANSI_ARGS_((ClientData instanceData, int mode)); -static int CloseProc _ANSI_ARGS_ ((ClientData instanceData, Tcl_Interp *interp)); -static int InputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int bufSize, int *errorCodePtr)); -static int OutputProc _ANSI_ARGS_((ClientData instanceData, - char *buf, int toWrite, int *errorCodePtr)); -static int GetOptionProc _ANSI_ARGS_ ((ClientData instanceData, - Tcl_Interp *interp, char *optionName, Tcl_DString *dsPtr)); -static void WatchProc _ANSI_ARGS_((ClientData instanceData, int mask)); -static int GetHandleProc _ANSI_ARGS_ ((ClientData instanceData, - int direction, ClientData *handlePtr)); -static void ChannelHandler _ANSI_ARGS_ ((ClientData clientData, int mask)); -static void ChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData)); +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, + char *buf, int toWrite, int *errorCodePtr)); +static int TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData, + Tcl_Interp *interp, 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: */ - +#ifdef TCL_CHANNEL_VERSION_2 +static Tcl_ChannelType tlsChannelType = { + "tls", /* Type name. */ + TCL_CHANNEL_VERSION_2, /* A NG channel */ + 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. */ +}; +#else static Tcl_ChannelType tlsChannelType = { "tls", /* Type name. */ - BlockModeProc, /* Set blocking/nonblocking mode.*/ - CloseProc, /* Close proc. */ - InputProc, /* Input proc. */ - OutputProc, /* Output proc. */ + TlsBlockModeProc, /* Set blocking/nonblocking mode.*/ + TlsCloseProc, /* Close proc. */ + TlsInputProc, /* Input proc. */ + TlsOutputProc, /* Output proc. */ NULL, /* Seek proc. */ NULL, /* Set option proc. */ - GetOptionProc, /* Get option proc. */ - WatchProc, /* Initialize notifier. */ - GetHandleProc, /* Get file handle out of channel. */ + TlsGetOptionProc, /* Get option proc. */ + TlsWatchProc, /* Initialize notifier. */ + TlsGetHandleProc, /* Get file handle out of channel. */ }; +#endif Tcl_ChannelType *Tls_ChannelType() { return &tlsChannelType; } /* *------------------------------------------------------------------- * - * BlockModeProc -- + * TlsBlockModeProc -- * * This procedure is invoked by the generic IO level * to set blocking and nonblocking modes * Results: * 0 if successful, errno when failed. @@ -84,11 +108,11 @@ * *------------------------------------------------------------------- */ static int -BlockModeProc(ClientData instanceData, /* Socket state. */ +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; @@ -96,18 +120,22 @@ 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 } /* *------------------------------------------------------------------- * - * CloseProc -- + * TlsCloseProc -- * * This procedure is invoked by the generic IO level to perform * channel-type-specific cleanup when a SSL socket based channel * is closed. * @@ -120,25 +148,25 @@ * Closes the socket of the channel. * *------------------------------------------------------------------- */ static int -CloseProc(ClientData instanceData, /* The socket to close. */ +TlsCloseProc(ClientData instanceData, /* The socket to close. */ Tcl_Interp *interp) /* For error reporting - unused. */ { State *statePtr = (State *) instanceData; - dprintf(stderr,"\nCloseProc(0x%x)", statePtr); + dprintf(stderr,"\nTlsCloseProc(0x%x)", statePtr); /* * Remove event handler to underlying channel, this could * be because we are closing for real, or being "unstacked". */ - +#ifndef TCL_CHANNEL_VERSION_2 Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - ChannelHandler, (ClientData) statePtr); - + TlsChannelHandler, (ClientData) statePtr); +#endif if (statePtr->timer != (Tcl_TimerToken)NULL) { Tcl_DeleteTimerHandler (statePtr->timer); statePtr->timer = (Tcl_TimerToken)NULL; } @@ -148,11 +176,11 @@ } /* *------------------------------------------------------------------- * - * InputProc -- + * TlsInputProc -- * * This procedure is invoked by the generic IO level * to read input from a SSL socket based channel. * * Results: @@ -165,11 +193,11 @@ * *------------------------------------------------------------------- */ static int -InputProc(ClientData instanceData, /* Socket state. */ +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. */ { @@ -219,11 +247,11 @@ } /* *------------------------------------------------------------------- * - * OutputProc -- + * TlsOutputProc -- * * This procedure is invoked by the generic IO level * to write output to a SSL socket based channel. * * Results: @@ -235,11 +263,11 @@ * *------------------------------------------------------------------- */ static int -OutputProc(ClientData instanceData, /* Socket state. */ +TlsOutputProc(ClientData instanceData, /* Socket state. */ char *buf, /* The data buffer. */ int toWrite, /* How many bytes to write? */ int *errorCodePtr) /* Where to store error code. */ { State *statePtr = (State *) instanceData; @@ -308,11 +336,11 @@ } /* *------------------------------------------------------------------- * - * GetOptionProc -- + * TlsGetOptionProc -- * * Computes an option value for a SSL socket based channel, or a * list of all options and their values. * * Note: This code is based on code contributed by John Haxby. @@ -326,19 +354,39 @@ * None. * *------------------------------------------------------------------- */ static int -GetOptionProc(ClientData instanceData, /* Socket state. */ +TlsGetOptionProc(ClientData instanceData, /* Socket state. */ Tcl_Interp *interp, /* For errors - can be NULL. */ char *optionName, /* Name of the option to * retrieve the value for, or * NULL to get all options and * their values. */ Tcl_DString *dsPtr) /* Where to store the computed value * initialized by caller. */ { +#ifdef TCL_CHANNEL_VERSION_2 + State *statePtr = (State *) instanceData; + Tcl_Channel downChan = Tls_GetParent(statePtr); + Tcl_DriverGetOptionProc *getOptionProc; + + getOptionProc = Tcl_ChannelGetOptionProc(Tcl_GetChannelType(downChan)); + if (getOptionProc != NULL) { + return (*getOptionProc)(Tcl_GetChannelInstanceData(downChan), + interp, optionName, dsPtr); + } else if (optionName == (char*) NULL) { + /* + * Request is query for all options, this is ok. + */ + return TCL_OK; + } + /* + * Request for a specific option has to fail, we don't have any. + */ + return TCL_ERROR; +#else State *statePtr = (State *) instanceData; size_t len = 0; if (optionName != (char *) NULL) { len = strlen(optionName); @@ -355,16 +403,17 @@ return TCL_OK; } } #endif return TCL_OK; +#endif } /* *------------------------------------------------------------------- * - * WatchProc -- + * TlsWatchProc -- * * Initialize the notifier to watch Tcl_Files from this channel. * * Results: * None. @@ -375,17 +424,52 @@ * *------------------------------------------------------------------- */ static void -WatchProc(ClientData instanceData, /* The socket state. */ +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; +#ifdef TCL_CHANNEL_VERSION_2 + Tcl_Channel downChan; + + statePtr->watchMask = mask; + + /* No channel handlers any more. We will be notified automatically + * about events on the channel below via a call to our + * 'TransformNotifyProc'. But we have to pass the interest down now. + * We are allowed to add additional 'interest' to the mask if we want + * to. But this transformation has no such interest. It just passes + * the request down, unchanged. + */ + + downChan = Tls_GetParent(statePtr); + + (Tcl_GetChannelType(downChan)) + ->watchProc(Tcl_GetChannelInstanceData(downChan), mask); + + /* + * Management of the internal timer. + */ + + if (statePtr->timer != (Tcl_TimerToken) NULL) { + Tcl_DeleteTimerHandler(statePtr->timer); + statePtr->timer = (Tcl_TimerToken) NULL; + } + if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) { + /* + * There is interest in readable events and we actually have + * data waiting, so generate a timer to flush that. + */ + statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY, + TlsChannelHandlerTimer, (ClientData) statePtr); + } +#else if (mask == statePtr->watchMask) return; if (statePtr->watchMask) { /* @@ -392,27 +476,28 @@ * Remove event handler to underlying channel, this could * be because we are closing for real, or being "unstacked". */ Tcl_DeleteChannelHandler(Tls_GetParent(statePtr), - ChannelHandler, (ClientData) 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, ChannelHandler, (ClientData) statePtr); + statePtr->watchMask, TlsChannelHandler, (ClientData) statePtr); } +#endif } /* *------------------------------------------------------------------- * - * GetHandleProc -- + * TlsGetHandleProc -- * * Called from Tcl_GetChannelFile to retrieve o/s file handler * from the SSL socket based channel. * * Results: @@ -422,23 +507,70 @@ * None. * *------------------------------------------------------------------- */ static int -GetHandleProc(ClientData instanceData, /* The socket state. */ +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); + 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; + } + + return mask; } +#ifndef TCL_CHANNEL_VERSION_2 /* *------------------------------------------------------* * - * ChannelHandler -- + * TlsChannelHandler -- * * ------------------------------------------------* * Handler called by Tcl as a result of * Tcl_CreateChannelHandler - to inform us of activity * on the underlying channel. @@ -453,13 +585,13 @@ * *------------------------------------------------------* */ static void -ChannelHandler (clientData, mask) -ClientData clientData; -int mask; +TlsChannelHandler (clientData, mask) + ClientData clientData; + int mask; { State *statePtr = (State *) clientData; dprintf(stderr, "HANDLER(0x%x)\n", mask); Tcl_Preserve( (ClientData)statePtr); @@ -501,41 +633,42 @@ if (statePtr->timer != (Tcl_TimerToken)NULL) { Tcl_DeleteTimerHandler(statePtr->timer); statePtr->timer = (Tcl_TimerToken)NULL; } - if ((mask & TCL_READABLE) && Tcl_InputBuffered (statePtr->self) > 0) { + 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, - ChannelHandlerTimer, (ClientData) statePtr); + TlsChannelHandlerTimer, (ClientData) statePtr); } Tcl_Release( (ClientData)statePtr); } +#endif /* *------------------------------------------------------* * - * ChannelHandlerTimer -- + * TlsChannelHandlerTimer -- * * ------------------------------------------------* * Called by the notifier (-> timer) to flush out * information waiting in channel buffers. * ------------------------------------------------* * * Sideeffects: - * As of 'ChannelHandler'. + * As of 'TlsChannelHandler'. * * Result: * None. * *------------------------------------------------------* */ static void -ChannelHandlerTimer (clientData) +TlsChannelHandlerTimer (clientData) ClientData clientData; /* Transformation to query */ { State *statePtr = (State *) clientData; int mask = 0; @@ -622,10 +755,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 +776,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 }