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.22 2004/12/23 23:51:40 patthoyts Exp $ +# RCS: @(#) $Id: tlsIO.test,v 1.23 2008/03/19 22:06:13 hobbs2 Exp $ # Running socket tests with a remote server: # ------------------------------------------ # # Some tests in socket.test depend on the existence of a remote server to @@ -70,11 +70,11 @@ } # The build dir is added as the first element of $PATH set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]] # Load the tls package -package require tls 1.5 +package require tls 1.6 set tlsServerPort 8048 # Specify where the certificates are @@ -337,12 +337,12 @@ set x } {ready done {}} if [info exists port] { incr port -} else { - set port [expr $tlsServerPort + [pid]%1024] +} else { + set port [expr {$tlsServerPort + [pid]%1024}] } test tlsIO-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script set f [open script w] @@ -1774,11 +1774,11 @@ close $f after 1000 exit vwait forever } close $f - + # Launch script2 and wait 5 seconds exec $::tcltest::tcltest script2 & after 5000 { set ok_to_proceed 1 } vwait ok_to_proceed @@ -1976,10 +1976,59 @@ lappend result [threadReap] set result } {hello 1} + +test tlsIO-14.1 {test tls::unimport} {socket} { + list [catch {tls::unimport} msg] $msg +} {1 {wrong # args: should be "tls::unimport channel"}} +test tlsIO-14.2 {test tls::unimport} {socket} { + list [catch {tls::unimport foo bar} msg] $msg +} {1 {wrong # args: should be "tls::unimport channel"}} +test tlsIO-14.3 {test tls::unimport} {socket} { + list [catch {tls::unimport bogus} msg] $msg +} {1 {can not find channel named "bogus"}} +test tlsIO-14.4 {test tls::unimport} {socket} { + # stdin can take different names as the "top" channel + list [catch {tls::unimport stdin} msg] \ + [string match {bad channel "*": not a TLS channel} $msg] +} {1 1} +test tlsIO-14.5 {test tls::unimport} {socket} { + set len 0 + set spurious 0 + set done 0 + proc readlittle {s} { + global spurious done len + set l [read $s 1] + if {[string length $l] == 0} { + if {![eof $s]} { + incr spurious + } else { + close $s + set done 1 + } + } else { + incr len [string length $l] + } + } + proc accept {s a p} { + fconfigure $s -blocking 0 + fileevent $s readable [list do_handshake $s readable readlittle \ + -buffering none] + } + set s [tls::socket \ + -certfile $serverCert -cafile $caCert -keyfile $serverKey \ + -server accept 8831] + set c [tls::socket \ + -certfile $clientCert -cafile $caCert -keyfile $clientKey \ + [info hostname] 8831] + # only the client gets tls::import + set res [tls::unimport $c] + list $res [catch {close $c} err] $err \ + [catch {close $s} err] $err +} {{} 0 {} 0 {}} # cleanup if {[string match sock* $commandSocket] == 1} { puts $commandSocket exit flush $commandSocket Index: tls.c ================================================================== --- tls.c +++ tls.c @@ -3,11 +3,11 @@ * some modifications: * Copyright (C) 2000 Ajuba Solutions * Copyright (C) 2002 ActiveState Corporation * Copyright (C) 2004 Starfish Systems * - * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.29 2008/03/19 21:31:24 hobbs2 Exp $ + * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.30 2008/03/19 22:06:13 hobbs2 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 @@ -57,10 +57,13 @@ static int VersionObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static int MiscObjCmd _ANSI_ARGS_ ((ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); + +static int UnimportObjCmd _ANSI_ARGS_ ((ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])); static SSL_CTX *CTX_Init _ANSI_ARGS_((State *statePtr, int proto, char *key, char *cert, char *CAdir, char *CAfile, char *ciphers)); #define TLS_PROTO_SSL2 0x01 @@ -875,10 +878,65 @@ } /* *------------------------------------------------------------------- * + * UnimportObjCmd -- + * + * This procedure is invoked to remove the topmost channel filter. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May modify the behavior of an IO channel. + * + *------------------------------------------------------------------- + */ + +static int +UnimportObjCmd(clientData, interp, objc, objv) + ClientData clientData; /* Not used. */ + Tcl_Interp *interp; + int objc; + Tcl_Obj *CONST objv[]; +{ + Tcl_Channel chan; /* The channel to set a mode on. */ + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "channel"); + return TCL_ERROR; + } + + chan = Tcl_GetChannel(interp, Tcl_GetString(objv[1]), NULL); + if (chan == (Tcl_Channel) NULL) { + return TCL_ERROR; + } + + if (channelTypeVersion == TLS_CHANNEL_VERSION_2) { + /* + * Make sure to operate on the topmost channel + */ + chan = Tcl_GetTopChannel(chan); + } + + if (Tcl_GetChannelType(chan) != Tls_ChannelType()) { + Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan), + "\": not a TLS channel", NULL); + return TCL_ERROR; + } + + if (Tcl_UnstackChannel(interp, chan) == TCL_ERROR) { + return TCL_ERROR; + } + + return TCL_OK; +} + +/* + *------------------------------------------------------------------- + * * CTX_Init -- construct a SSL_CTX instance * * Results: * A valid SSL_CTX instance or NULL. * @@ -1473,10 +1531,13 @@ Tcl_CreateObjCommand(interp, "tls::handshake", HandshakeObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "tls::import", ImportObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + + Tcl_CreateObjCommand(interp, "tls::unimport", UnimportObjCmd, + (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "tls::status", StatusObjCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd, Index: tls.htm ================================================================== --- tls.htm +++ tls.htm @@ -27,10 +27,11 @@
tls::socket ?-server command? ?options? port
tls::handshake channel
tls::status ?-local? channel
tls::import channel ?options?
+
tls::unimport channel
tls::ciphers protocol ?verbose?
tls::version
COMMANDS
@@ -48,20 +49,21 @@ toolkit.

SYNOPSIS

package require Tcl 8.2
-package require tls 1.5
+package require tls 1.6

tls::init ?options?
tls::socket ?options? host port
tls::socket ?-server command? ?options? port
tls::status ?-local? channel
tls::handshake channel

tls::import channel ?options?
+tls::unimport channel
tls::ciphers protocol ?verbose?
tls::version

@@ -206,10 +208,17 @@
-tls1 bool
Enable use of TLS v1. (default: false)
+
+
tls::unimport channel
+
Provided for symmetry to tls::import, this + unstacks the SSL-enabling of a regular Tcl channel. An error + is thrown if TLS is not the top stacked channel type.
+
+
tls::ciphers protocol ?verbose?
Returns list of supported ciphers based on the protocol you supply, which must be one of ssl2, ssl3, or tls1.