Index: ChangeLog
==================================================================
--- ChangeLog
+++ ChangeLog
@@ -1,5 +1,41 @@
+2000-07-13 Jeff Hobbs <hobbs@scriptics.com>
+
+ * 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 <hobbs@scriptics.com>
+
+ * 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 <hobbs@scriptics.com>
+
+ * 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 <stanton@ajubasolutions.com>
* 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 <matt@novadigm.com>
*
- * $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 <matt@novadigm.com>
*
- * $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, <buf>, %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, <buf>, %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 <matt@novadigm.com>
*
- * $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 <matt@sensus.org>.
- *
- * We were unable to find the channel structure for this
- * transformation in the chain of stacked channel. This
- * means that we are currently in the process of unstacking
- * it *and* there were some bytes waiting which are now
- * flushed. In this situation the pointer to the channel
- * itself already refers to the parent channel we have to
- * write the bytes into, so we return that.
- */
- return statePtr->self;
- }
- self = next;
- }
-
- return Tcl_GetStackedChannel (self);
+ Tcl_Channel self = statePtr->self;
+ Tcl_Channel next;
+
+ while ((ClientData) statePtr != Tcl_GetChannelInstanceData (self)) {
+ next = Tcl_GetStackedChannel (self);
+ if (next == (Tcl_Channel) NULL) {
+ /* 09/24/1999 Unstacking bug,
+ * found by Matt Newman <matt@sensus.org>.
+ *
+ * We were unable to find the channel structure for this
+ * transformation in the chain of stacked channel. This
+ * means that we are currently in the process of unstacking
+ * it *and* there were some bytes waiting which are now
+ * flushed. In this situation the pointer to the channel
+ * itself already refers to the parent channel we have to
+ * write the bytes into, so we return that.
+ */
+ return statePtr->self;
+ }
+ self = next;
+ }
+
+ return Tcl_GetStackedChannel (self);
+#endif
#endif
}