Check-in [fb9a612600]
Bounty program for improvements to Tcl and certain Tcl packages.
Overview
Comment: * 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.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | tls-1-3-io-rewrite
Files: files | file ages | folders
SHA1: fb9a612600e3a1cead4cb52b056bab1c9ad58694
User & Date: hobbs on 2000-07-11 04:58:45
Other Links: branch diff | manifest | tags
Context
2000-07-12
01:54
* 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. check-in: 107ae51e18 user: hobbs tags: tls-1-3-io-rewrite
2000-07-11
04:58
* 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. check-in: fb9a612600 user: hobbs tags: tls-1-3-io-rewrite
2000-06-28
18:24
Added HPUX to list of known platforms. check-in: c7d3de2764 user: wart tags: trunk
Changes

Modified ChangeLog from [cd26bc6332] to [02913f3b74].














1
2
3
4
5
6
7













2000-06-05  Scott Stanton  <[email protected]>

	* Makefile.in: Fixed broken test target.

	* tlsInt.h: 
	* tls.c: Cleaned up declarations of Tls_Clean to avoid errors on
	Windows (lint).
>
>
>
>
>
>
>
>
>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
2000-07-10  Jeff Hobbs  <[email protected]>

	* 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  <[email protected]>

	* Makefile.in: Fixed broken test target.

	* tlsInt.h: 
	* tls.c: Cleaned up declarations of Tls_Clean to avoid errors on
	Windows (lint).

Modified tests/tlsIO.test from [321099ebe7] to [7a362e85d6].

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.
#
# 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.14 2000/06/08 00:06:40 aborr 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











|







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.
#
# 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.14.2.1 2000/07/11 04:58:46 hobbs 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
70
71
72
73
74
75
76

77
78
79
80
81
82
83
# Load the tls package

package require tls

set tlsServerPort 8048

set certsDir [file join [file dirname [info script]] certs] 


set serverCert [file join $certsDir server.pem]
set clientCert [file join $certsDir client.pem]
set caCert [file join $certsDir cacert.pem]
set serverKey [file join $certsDir skey.pem]
set clientKey [file join $certsDir ckey.pem]







>







70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
# Load the tls package

package require tls

set tlsServerPort 8048

set certsDir [file join [file dirname [info script]] certs] 
#set certsDir ~hobbs/cvs/tls/tests/certs

set serverCert [file join $certsDir server.pem]
set clientCert [file join $certsDir client.pem]
set caCert [file join $certsDir cacert.pem]
set serverKey [file join $certsDir skey.pem]
set clientKey [file join $certsDir ckey.pem]

330
331
332
333
334
335
336


337
338
339
340
341
342
343
    global port
    if {[catch {tls::socket -myport $port \
	-certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 8829} sock]} {
        set x $sock
	catch {close [tls::socket 127.0.0.1 8829]}
    } else {


        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x






>
>







331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
    global port
    if {[catch {tls::socket -myport $port \
	-certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 8829} sock]} {
        set x $sock
	catch {close [tls::socket 127.0.0.1 8829]}
    } else {
	# HOBBS handshake shouldn't be necessary
	tls::handshake $sock
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
367
368
369
370
371
372
373


374
375
376
377
378
379
380
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -myaddr 127.0.0.1 \
	-certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 8830} sock]} {
        set x $sock
    } else {


        puts $sock hello
	catch {flush $sock}
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x






>
>







370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -myaddr 127.0.0.1 \
	-certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 8830} sock]} {
        set x $sock
    } else {
	# HOBBS handshake shouldn't be necessary
	tls::handshake $sock
        puts $sock hello
	catch {flush $sock}
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
403
404
405
406
407
408
409


410
411
412
413
414
415
416
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
	-keyfile $clientKey [info hostname] 8831} sock]} {
        set x $sock
    } else {


        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x






>
>







408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
	-keyfile $clientKey [info hostname] 8831} sock]} {
        set x $sock
    } else {
	# HOBBS handshake shouldn't be necessary
	tls::handshake $sock
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
439
440
441
442
443
444
445


446
447
448
449
450
451
452
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 8832} sock]} {
        set x $sock
    } else {


        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x






>
>







446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
    close $f
    set f [open "|[list $::tcltest::tcltest script]" r]
    gets $f x
    if {[catch {tls::socket -certfile $clientCert -cafile $caCert \
	-keyfile $clientKey 127.0.0.1 8832} sock]} {
        set x $sock
    } else {
	# HOBBS handshake shouldn't be necessary
	tls::handshake $sock
        puts $sock hello
	flush $sock
        lappend x [gets $f]
        close $sock
    }
    close $f
    set x
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test tlsIO-4.1 {server with several clients} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
    	package require tls
	gets stdin
    }
    puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]"






|







767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
    close $s2
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test tlsIO-4.1 {server with several clients} {hangsHobbs socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
    	package require tls
	gets stdin
    }
    puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]"

Modified tls.c from [1fe77384fc] to [f0ce1e5480].

1
2
3
4
5
6
7
8
9
10
11
/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6 2000/06/06 01:34:11 welch 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
 *


|







1
2
3
4
5
6
7
8
9
10
11
/*
 * Copyright (C) 1997-1999 Matt Newman <[email protected]>
 *
 * $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
 * OpenSSL 0.9.2B
 *
536
537
538
539
540
541
542






543
544
545
546
547
548
549
        return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }






    if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
        Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
                "\": not a TLS channel", NULL);
        return TCL_ERROR;
    }
    statePtr = (State *)Tcl_GetChannelInstanceData( chan);







>
>
>
>
>
>







536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
        return TCL_ERROR;
    }

    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;
    }
    statePtr = (State *)Tcl_GetChannelInstanceData( chan);

628
629
630
631
632
633
634






635
636
637
638
639
640
641
        return TCL_ERROR;
    }

    chan = Tcl_GetChannel(interp, Tcl_GetStringFromObj(objv[1], NULL), NULL);
    if (chan == (Tcl_Channel) NULL) {
        return TCL_ERROR;
    }







    for (idx = 2; idx < objc; idx++) {
	char *opt = Tcl_GetStringFromObj(objv[idx], NULL);

	if (opt[0] != '-')
	    break;







>
>
>
>
>
>







634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
        return TCL_ERROR;
    }

    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] != '-')
	    break;

676
677
678
679
680
681
682






683
684
685
686
687
688
689
    if (model != NULL) {
	int mode;
	/* Get the "model" context */
	chan = Tcl_GetChannel( interp, model, &mode);
	if (chan == (Tcl_Channel)0) {
	    return TCL_ERROR;
	}






	if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
	    Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
		    "\": not a TLS channel", NULL);
	    return TCL_ERROR;
	}
	statePtr = (State *)Tcl_GetChannelInstanceData( chan);
	ctx = statePtr->ctx;






>
>
>
>
>
>







688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
    if (model != NULL) {
	int mode;
	/* 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;
	}
	statePtr = (State *)Tcl_GetChannelInstanceData( chan);
	ctx = statePtr->ctx;
719
720
721
722
723
724
725




726
727
728

729
730
731
732
733
734
735
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2
    statePtr->parent = chan;
    statePtr->self = Tcl_ReplaceChannel( interp,
				Tls_ChannelType(), (ClientData) statePtr,
			       (TCL_READABLE | TCL_WRITABLE), statePtr->parent);
#else




    statePtr->self = chan;
    Tcl_StackChannel( interp, Tls_ChannelType(), (ClientData) statePtr,
			       (TCL_READABLE | TCL_WRITABLE), chan);

#endif
    if (statePtr->self == (Tcl_Channel) NULL) {
	/*
	 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
	 */
	Tls_Free((char *) statePtr);
        return TCL_ERROR;






>
>
>
>


|
>







737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2
    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);
#endif
#endif
    if (statePtr->self == (Tcl_Channel) NULL) {
	/*
	 * No use of Tcl_EventuallyFree because no possible Tcl_Preserve.
	 */
	Tls_Free((char *) statePtr);
        return TCL_ERROR;
986
987
988
989
990
991
992






993
994
995
996
997
998
999
    }
    channelName = Tcl_GetStringFromObj(objv[1], NULL);

    chan = Tcl_GetChannel( interp, channelName, &mode);
    if (chan == (Tcl_Channel)0) {
	return TCL_ERROR;
    }






    if (Tcl_GetChannelType(chan) != Tls_ChannelType()) {
        Tcl_AppendResult(interp, "bad channel \"", Tcl_GetChannelName(chan),
                "\": not a TLS channel", NULL);
        return TCL_ERROR;
    }
    statePtr = (State *)Tcl_GetChannelInstanceData( chan);
    peer = SSL_get_peer_certificate(statePtr->ssl);






>
>
>
>
>
>







1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
    }
    channelName = Tcl_GetStringFromObj(objv[1], NULL);

    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;
    }
    statePtr = (State *)Tcl_GetChannelInstanceData( chan);
    peer = SSL_get_peer_certificate(statePtr->ssl);

Modified tlsBIO.c from [e6c3698fee] to [a638221c0a].

1
2
3
4
5
6
7
8
9
10
11
/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2 2000/01/20 01:51:39 aborr Exp $
 *
 * Provides BIO layer to interface openssl to Tcl.
 */

#include "tlsInt.h"

/*


|







1
2
3
4
5
6
7
8
9
10
11
/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $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"

/*
59
60
61
62
63
64
65



66

67
68
69
70
71
72
73
    int bufLen;
{
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    int ret;

    dprintf(stderr,"\nBioWrite(0x%x, <buf>, %d) [0x%x]", bio, bufLen, chan);




    ret = Tcl_Write( chan, buf, bufLen);


    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);

    if (ret == 0) {






>
>
>

>







59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
    int bufLen;
{
    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);

    if (ret == 0) {
90
91
92
93
94
95
96



97

98
99
100
101
102
103
104
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    int ret = 0;

    dprintf(stderr,"\nBioRead(0x%x, <buf>, %d) [0x%x]", bio, bufLen, chan);

    if (buf == NULL) return 0;




    ret = Tcl_Read( chan, buf, bufLen);


    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);

    if (ret == 0) {






>
>
>

>







94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
    Tcl_Channel chan = Tls_GetParent((State*)bio->ptr);
    int ret = 0;

    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);

    if (ret == 0) {

Modified tlsIO.c from [83d2c33ca1] to [3096d1d31d].

1
2
3
4
5
6
7
8
9
10
11
/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7 2000/06/05 18:09:54 welch 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
 *
 * Addition credit is due for Andreas Kupries ([email protected]), for


|







1
2
3
4
5
6
7
8
9
10
11
/*
 * Copyright (C) 1997-2000 Matt Newman <[email protected]>
 *
 * $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
 *
 * Addition credit is due for Andreas Kupries ([email protected]), for
46
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
72
static void	ChannelHandler _ANSI_ARGS_ ((ClientData clientData, int mask));
static void	ChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData));

/*
 * This structure describes the channel type structure for TCP socket
 * based IO:
 */


















static Tcl_ChannelType tlsChannelType = {
    "tls",		/* Type name. */
    BlockModeProc,	/* Set blocking/nonblocking mode.*/
    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. */
};


Tcl_ChannelType *Tls_ChannelType()
{
    return &tlsChannelType;
}

/*






|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>







46
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
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
static void	ChannelHandler _ANSI_ARGS_ ((ClientData clientData, int mask));
static void	ChannelHandlerTimer _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 */
    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. */
    OutputProc,		/* Output proc. */
    NULL,		/* Seek proc. */
    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;
}

/*
94
95
96
97
98
99
100



101
102

103
104
105
106
107
108
109
    State *statePtr = (State *) instanceData;

    if (mode == TCL_MODE_NONBLOCKING) {
	statePtr->flags |= TLS_TCL_ASYNC;
    } else {
	statePtr->flags &= ~(TLS_TCL_ASYNC);
    }



    return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
		"-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1");

}

/*
 *-------------------------------------------------------------------
 *
 * CloseProc --
 *






>
>
>


>







112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
    State *statePtr = (State *) instanceData;

    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 --
 *
333
334
335
336
337
338
339




















340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359

360
361
362
363
364
365
366
                 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. */
{




















    State *statePtr = (State *) instanceData;
    size_t len = 0;

    if (optionName != (char *) NULL) {
        len = strlen(optionName);
    }
#if 0
    if ((len == 0) ||
        ((len > 1) && (optionName[1] == 'c') &&
         (strncmp(optionName, "-cipher", len) == 0))) {
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-cipher");
        }
        Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
        if (len) {
            return TCL_OK;
        }
    }
#endif
    return TCL_OK;

}

/*
 *-------------------------------------------------------------------
 *
 * WatchProc --
 *






>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>




















>







355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
                 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);
    }
#if 0
    if ((len == 0) ||
        ((len > 1) && (optionName[1] == 'c') &&
         (strncmp(optionName, "-cipher", len) == 0))) {
        if (len == 0) {
            Tcl_DStringAppendElement(dsPtr, "-cipher");
        }
        Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
        if (len) {
            return TCL_OK;
        }
    }
#endif
    return TCL_OK;
#endif
}

/*
 *-------------------------------------------------------------------
 *
 * WatchProc --
 *
620
621
622
623
624
625
626



627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651

652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667

668
    }
}

Tcl_Channel
Tls_GetParent( statePtr )
    State *statePtr;
{



#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
     * transform will leave our internal pointer unchanged,
     * and thus pointing to the new transform, and not the
     * Channel structure containing the saved state of this
     * transform. This is the price to pay for leaving
     * Tcl_Channel references intact. The only other solution
     * is an extension of Tcl_ChannelType with another driver
     * procedure to notify a Channel about the (un)stacking.
     *
     * 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 <[email protected]>.

       *
       * 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

}






>
>
>


















|
|

|
|
|
|
>
|
|
|
|
|
|
|
|
|
|
|
|
|

|

>

663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
    }
}

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
     * transform will leave our internal pointer unchanged,
     * and thus pointing to the new transform, and not the
     * Channel structure containing the saved state of this
     * transform. This is the price to pay for leaving
     * Tcl_Channel references intact. The only other solution
     * is an extension of Tcl_ChannelType with another driver
     * procedure to notify a Channel about the (un)stacking.
     *
     * 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 <[email protected]>.
	     *
	     * 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
}