Check-in [fb9a612600]

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

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 2000-07-11 04:58:45
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

Changes to ChangeLog.















1
2
3
4
5
6
7














2000-06-05  Scott Stanton  <stanton@ajubasolutions.com>

	* 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  <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: 
	* tls.c: Cleaned up declarations of Tls_Clean to avoid errors on
	Windows (lint).

Changes to tests/tlsIO.test.

6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
70
71
72
73
74
75
76

77
78
79
80
81
82
83
...
330
331
332
333
334
335
336


337
338
339
340
341
342
343
...
367
368
369
370
371
372
373


374
375
376
377
378
379
380
...
403
404
405
406
407
408
409


410
411
412
413
414
415
416
...
439
440
441
442
443
444
445


446
447
448
449
450
451
452
...
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
#
# 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
................................................................................
# 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]

................................................................................
    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
................................................................................
    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
................................................................................
    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
................................................................................
    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
................................................................................
    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 \]"







|







 







>







 







>
>







 







>
>







 







>
>







 







>
>







 







|







6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
..
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
...
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
...
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
...
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
...
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
...
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
#
# 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
................................................................................
# 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]

................................................................................
    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
................................................................................
    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
................................................................................
    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
................................................................................
    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
................................................................................
    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 \]"

Changes to tls.c.

1
2
3
4
5
6
7
8
9
10
11
...
536
537
538
539
540
541
542






543
544
545
546
547
548
549
...
628
629
630
631
632
633
634






635
636
637
638
639
640
641
...
676
677
678
679
680
681
682






683
684
685
686
687
688
689
...
719
720
721
722
723
724
725




726
727
728

729
730
731
732
733
734
735
...
986
987
988
989
990
991
992






993
994
995
996
997
998
999
/*
 * 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 $
 *
 * 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
 *
................................................................................
        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);

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

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

#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;
................................................................................
    }
    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);



|







 







>
>
>
>
>
>







 







>
>
>
>
>
>







 







>
>
>
>
>
>







 







>
>
>
>


|
>







 







>
>
>
>
>
>







1
2
3
4
5
6
7
8
9
10
11
...
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
...
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
...
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
...
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
....
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
/*
 * Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com>
 *
 * $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
 *
................................................................................
        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);

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

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

#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;
................................................................................
    }
    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);

Changes to tlsBIO.c.

1
2
3
4
5
6
7
8
9
10
11
..
59
60
61
62
63
64
65



66

67
68
69
70
71
72
73
..
90
91
92
93
94
95
96



97

98
99
100
101
102
103
104
/*
 * 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 $
 *
 * Provides BIO layer to interface openssl to Tcl.
 */

#include "tlsInt.h"

/*
................................................................................
    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) {
................................................................................
    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) {



|







 







>
>
>

>







 







>
>
>

>







1
2
3
4
5
6
7
8
9
10
11
..
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
..
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
/*
 * Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
 *
 * $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"

/*
................................................................................
    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) {
................................................................................
    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) {

Changes to tlsIO.c.

1
2
3
4
5
6
7
8
9
10
11
..
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
..
94
95
96
97
98
99
100



101
102

103
104
105
106
107
108
109
...
333
334
335
336
337
338
339




















340
341
342
343
344
345
346
...
353
354
355
356
357
358
359

360
361
362
363
364
365
366
...
620
621
622
623
624
625
626



627
628
629
630
631
632
633
...
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
/*
 * 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 $
 *
 * 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 (a.kupries@westend.com), for
................................................................................
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;
}
 
/*
................................................................................
    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 --
 *
................................................................................
                 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
................................................................................
        Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
        if (len) {
            return TCL_OK;
        }
    }
#endif
    return TCL_OK;

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

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

}



|







 







<
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>












>







 







>
>
>


>







 







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







 







>







 







>
>
>







 







|
|

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

|

>

1
2
3
4
5
6
7
8
9
10
11
..
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
...
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
...
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
...
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
...
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
...
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
/*
 * Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
 *
 * $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 (a.kupries@westend.com), for
................................................................................
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;
}
 
/*
................................................................................
    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 --
 *
................................................................................
                 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
................................................................................
        Tcl_DStringAppendElement(dsPtr, SSL_get_cipher(statePtr->ssl));
        if (len) {
            return TCL_OK;
        }
    }
#endif
    return TCL_OK;
#endif
}
 
/*
 *-------------------------------------------------------------------
 *
 * WatchProc --
 *
................................................................................
    }
}

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