TclTLS
Check-in [61890c4886]
Login
HomeTimelineDownloadBrowse SourceBranchesTagsTicketsWiki
Overview
Comment: * tests/tlsIO.test (tlsIO-14.*): Add tls::unimport for symmetry * tls.htm, tls.c (UnimportObjCmd): to tls::import. [Bug 1203273]
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 61890c4886b0607f2753b1709614ed2da10e3669
User & Date: hobbs2 on 2008-03-19 22:06:13
Other Links: manifest | tags
Context
2008-03-19
22:09
* aclocal.m4: improve --with-ssl-dir check. check-in: 0adce51010 user: hobbs2 tags: trunk
22:06
* tests/tlsIO.test (tlsIO-14.*): Add tls::unimport for symmetry * tls.htm, tls.c (UnimportObjCmd): to tls::import. [Bug 1203273] check-in: 61890c4886 user: hobbs2 tags: trunk
21:31
Use better Eval APIs, cleaner Tcl_Obj-handling. check-in: 5804017ad3 user: hobbs2 tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Modified tests/tlsIO.test from [a8b5647509] to [18affbd0b0]. 

1
2
3
4
5
6
7
8
9
10
11
12
13

14
15
16
17
18
19
20

1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20













-
+








# Commands tested in this file: socket.                          -*- tcl -*-
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
# 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
# which they connect. The remote server must be an instance of tcltest and it
# must run the script found in the file "remote.tcl" in this directory. You
︙
68
69
70
71
72
73
74
75

76
77
78
79
80
81
82

68
69
70
71
72
73
74

75
76
77
78
79
80
81
82








-
+








    package require tcltest
    namespace import -force ::tcltest::*
}

# 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

set certsDir	[file join [file dirname [info script]] certs]
set serverCert	[file join $certsDir server.pem]
︙
335
336
337
338
339
340
341
342
343


344
345
346
347
348
349
350

335
336
337
338
339
340
341


342
343
344
345
346
347
348
349
350








-
-
+
+








    lappend x [gets $f]
    close $f
    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]
    puts $f {
	set auto_path [linsert $auto_path 0 [lindex [split $env(PATH) ";:"] 0]]
︙
1772
1773
1774
1775
1776
1777
1778
1779

1780
1781
1782
1783
1784
1785
1786

1772
1773
1774
1775
1776
1777
1778

1779
1780
1781
1782
1783
1784
1785
1786








-
+








	}
	exec $tclsh script1 &
	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

    # If we can still connect to the server, the socket got inherited.
︙
1974
1975
1976
1977
1978
1979
1980

















































1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991

1974
1975
1976
1977
1978
1979
1980
1981
1982
1983
1984
1985
1986
1987
1988
1989
1990
1991
1992
1993
1994
1995
1996
1997
1998
1999
2000
2001
2002
2003
2004
2005
2006
2007
2008
2009
2010
2011
2012
2013
2014
2015
2016
2017
2018
2019
2020
2021
2022
2023
2024
2025
2026
2027
2028
2029
2030
2031
2032
2033
2034
2035
2036
2037
2038
2039
2040








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+













    after 2000
    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
}
catch {close $commandSocket}
catch {close $remoteProcChan}
::tcltest::cleanupTests
flush stdout
return

Modified tls.c from [66ecdb7d9a] to [863315bd45]. 

1
2
3
4
5
6
7
8

9
10
11
12
13
14
15

1
2
3
4
5
6
7

8
9
10
11
12
13
14
15








-
+








/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 * 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
 * OpenSSL 0.9.2B
 *
︙
55
56
57
58
59
60
61



62
63
64
65
66
67
68

55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71








+
+
+








			Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));

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
#define TLS_PROTO_SSL3	0x02
#define TLS_PROTO_TLS1	0x04
︙
873
874
875
876
877
878
879























































880
881
882
883
884
885
886

876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944








+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+








	    TCL_VOLATILE);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * 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.
 *
 * Side effects:
 *	constructs SSL context (CTX)
︙
1471
1472
1473
1474
1475
1476
1477



1478
1479
1480
1481
1482
1483
1484

1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545








+
+
+








	    (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::unimport", UnimportObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);

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

    Tcl_CreateObjCommand(interp, "tls::version", VersionObjCmd,
	    (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
︙

Modified tls.htm from [c4760bdd91] to [7d8a6ea6de].

︙
25
26
27
28
29
30
31

32
33
34
35
36
37
38

25
26
27
28
29
30
31
32
33
34
35
36
37
38
39








+








            <dd><b>tls::init </b><i>?options?</i> </dd>
            <dd><b>tls::socket </b><em>?options? host port</em></dd>
            <dd><b>tls::socket</b><em> ?-server command?
                ?options? port</em></dd>
            <dd><b>tls::handshake</b><em> channel</em></dd>
            <dd><b>tls::status </b><em>?-local? channel</em></dd>
            <dd><b>tls::import</b><em> channel ?options?</em></dd>
            <dd><b>tls::unimport</b><em> channel</em></dd>
            <dd><b>tls::ciphers </b><em>protocol ?verbose?</em></dd>
            <dd><b>tls::version</b></dd>
        </dl>
    </dd>
    <dd><a href="#COMMANDS">COMMANDS</a></dd>
    <dd><a href="#CALLBACK OPTIONS">CALLBACK OPTIONS</a></dd>
    <dd><a href="#HTTPS EXAMPLE">HTTPS EXAMPLE</a></dd>
︙
46
47
48
49
50
51
52
53

54
55
56
57
58
59
60
61
62

63
64
65
66
67
68
69

47
48
49
50
51
52
53

54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71








-
+









+









<p><strong>tls</strong> - binding to <strong>OpenSSL</strong>
toolkit.</p>

<h3><a name="SYNOPSIS">SYNOPSIS</a></h3>

<p><b>package require Tcl 8.2</b><br>
<b>package require tls 1.5</b><br>
<b>package require tls 1.6</b><br>
<br>
<a href="#tls::init"><b>tls::init </b><i>?options?</i><br>
</a><a href="#tls::socket"><b>tls::socket </b><em>?options? host
port</em><br>
<b>tls::socket</b><em> ?-server command? ?options? port</em><br>
</a><a href="#tls::status"><b>tls::status </b><em>?-local? channel</em><br>
</a><a href="#tls::handshake"><b>tls::handshake</b><em> channel</em></a><br>
<br>
<a href="#tls::import"><b>tls::import </b><i>channel ?options?</i></a><br>
<a href="#tls::unimport"><b>tls::unimport </b><i>channel</i></a><br>
<a href="#tls::ciphers protocol ?verbose?"><strong>tls::ciphers</strong>
<em>protocol ?verbose?</em></a><br>
<a href="#tls::version"><b>tls::version</b></a>
</p>

<h3><a name="DESCRIPTION">DESCRIPTION</a></h3>
︙
204
205
206
207
208
209
210







211
212
213
214
215
216
217

206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226








+
+
+
+
+
+
+








        <dt><strong>-ssl3 </strong><em>bool</em></dt>
        <dd>Enable use of SSL v3. (<strong>default</strong>: <em>true</em>)</dd>
        <dt>-<strong>tls1</strong> <em>bool</em></dt>
        <dd>Enable use of TLS v1. (<strong>default</strong>: <em>false</em>)</dd>
    </dl>
</blockquote>

<dl>
    <dt><a name="tls::unimport"><b>tls::unimport </b><i>channel</i></a></dt>
    <dd>Provided for symmetry to <strong>tls::import</strong>, this
      unstacks the SSL-enabling of a regular Tcl channel.  An error
      is thrown if TLS is not the top stacked channel type.</dd>
</dl>

<dl>
    <dt><a name="tls::ciphers protocol ?verbose?"><strong>tls::ciphers</strong>
        <em>protocol ?verbose?</em></a></dt>
    <dd>Returns list of supported ciphers based on the <em>protocol</em>
        you supply, which must be one of <em>ssl2, ssl3, or tls1</em>.
        If <em>verbose</em> is specified as true then a verbose,
        semi-human readable list is returned providing additional
︙

Powered by Fossil · RSS