1
2
3
4
5
6
7
8
9
10
11
|
1
2
3
4
5
6
7
8
9
10
11
|
-
+
|
/*
* Copyright (C) 1997-1999 Matt Newman <matt@novadigm.com>
*
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.8 2000/08/14 21:55:12 hobbs Exp $
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.9 2000/08/15 00:02:08 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
*
|
︙ | | |
84
85
86
87
88
89
90
91
92
93
94
95
96
97
|
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
+
+
+
+
+
|
if ((dh->p == NULL) || (dh->g == NULL))
return(NULL);
return(dh);
}
#endif
/*
* Defined in Tls_Init to determine what kind of channels we are using
* (old-style 8.2.0-8.3.1 or new-style 8.3.2+).
*/
int channelTypeVersion;
/*
* We lose the tcl password callback when we use the RSA BSAFE SSL-C 1.1.2
* libraries instead of the current OpenSSL libraries.
*/
#ifdef BSAFE
|
︙ | | |
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
|
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
|
-
-
-
-
-
+
+
+
+
+
-
+
|
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);
if (channelTypeVersion == TLS_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);
|
︙ | | |
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
|
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
|
-
-
-
-
-
+
+
+
+
+
-
+
|
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);
if (channelTypeVersion == TLS_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;
|
︙ | | |
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
|
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
|
-
-
-
-
-
+
+
+
+
+
-
+
|
if (model != NULL) {
int mode;
/* Get the "model" context */
chan = Tcl_GetChannel(interp, model, &mode);
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);
if (channelTypeVersion == TLS_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;
|
︙ | | |
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
|
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
|
-
-
+
+
-
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
-
+
|
/*
* We need to make sure that the channel works in binary (for the
* encryption not to get goofed up).
* We only want to adjust the buffering in pre-v2 channels, where
* each channel in the stack maintained its own buffers.
*/
Tcl_SetChannelOption(interp, chan, "-translation", "binary");
#ifndef TCL_CHANNEL_VERSION_2
Tcl_SetChannelOption(interp, chan, "-buffering", "none");
if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
Tcl_SetChannelOption(interp, chan, "-buffering", "none");
#endif
#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);
if (channelTypeVersion == TLS_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;
}
|
︙ | | |
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
|
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
|
-
-
-
-
-
+
+
+
+
+
-
+
|
}
channelName = Tcl_GetStringFromObj(objv[1], NULL);
chan = Tcl_GetChannel(interp, channelName, &mode);
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);
if (channelTypeVersion == TLS_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);
|
︙ | | |
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
|
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
|
+
-
+
-
+
+
+
-
+
+
+
+
+
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
*-------------------------------------------------------------------
*/
int
Tls_Init(Tcl_Interp *interp) /* Interpreter in which the package is
* to be made available. */
{
int major, minor, release, serial;
#if TCL_MAJOR_VERSION >= 8 && TCL_MINOR_VERSION >= 2
/*
* The original 8.2.0 stacked channel implementation (and the patch
* that preceded it) had problems with scalability and robustness.
* These were address in 8.3.2 / 8.4a2, so we now require that as a
* minimum for TLS 1.4+.
* minimum for TLS 1.4+. We only support 8.2+ now (8.3.2+ preferred).
*/
if (
#ifdef USE_TCL_STUBS
if (Tcl_InitStubs(interp, "8.3.2", 0) == NULL) {
Tcl_InitStubs(interp, "8.2", 0)
#else
Tcl_PkgRequire(interp, "Tcl", "8.2", 0)
#endif
== NULL) {
return TCL_ERROR;
}
#endif
/*
* Get the version so we can runtime switch on available functionality.
* TLS should really only be used in 8.3.2+, but the other works for
* some limited functionality, so an attempt at support is made.
*/
Tcl_GetVersion(&major, &minor, &release, &serial);
if ((major > 8) || ((major == 8) && ((minor > 3) || ((minor == 3) &&
(release == TCL_FINAL_RELEASE) && (serial >= 2))))) {
/* 8.3.2+ */
channelTypeVersion = TLS_CHANNEL_VERSION_2;
} else {
/* 8.2.0 - 8.3.1 */
channelTypeVersion = TLS_CHANNEL_VERSION_1;
}
if (SSL_library_init() != 1) {
Tcl_AppendResult(interp, "could not initialize SSL library", NULL);
return TCL_ERROR;
}
SSL_load_error_strings();
ERR_load_crypto_strings();
|
︙ | | |
1
2
3
4
5
6
7
8
9
10
11
|
1
2
3
4
5
6
7
8
9
10
11
|
-
+
|
/*
* Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
*
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.3 2000/07/27 01:58:18 hobbs Exp $
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.4 2000/08/15 00:02:08 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
74
75
76
77
|
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);
if (channelTypeVersion == TLS_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) {
|
︙ | | |
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
-
-
-
-
+
+
+
+
-
+
|
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);
if (channelTypeVersion == TLS_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) {
|
︙ | | |
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
|
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
|
-
-
-
-
-
+
+
+
+
-
-
-
-
-
|
case BIO_CTRL_WPENDING:
ret = 0;
break;
case BIO_CTRL_DUP:
break;
case BIO_CTRL_FLUSH:
dprintf(stderr, "BIO_CTRL_FLUSH\n");
if (
#ifdef TCL_CHANNEL_VERSION_2
Tcl_WriteRaw(chan, "", 0) >= 0
#else
Tcl_Flush(chan) == TCL_OK
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
ret = ((Tcl_WriteRaw(chan, "", 0) >= 0) ? 1 : -1);
} else {
ret = ((Tcl_Flush(chan) == TCL_OK) ? 1 : -1);
#endif
) {
ret = 1;
} else {
ret = -1;
}
break;
default:
ret = 0;
break;
}
return(ret);
|
︙ | | |
1
2
3
4
5
6
7
8
9
10
11
|
1
2
3
4
5
6
7
8
9
10
11
|
-
+
|
/*
* Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
*
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.8 2000/07/27 01:58:18 hobbs Exp $
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.9 2000/08/15 00:02:08 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
|
︙ | | |
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
91
92
93
94
95
96
97
98
99
100
|
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
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
-
-
+
+
+
+
+
+
+
-
+
-
-
+
+
+
+
+
+
+
+
-
+
-
+
+
+
+
|
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 = {
static Tcl_ChannelType tlsChannelType2 = {
"tls", /* Type name. */
#ifndef TCL_CHANNEL_VERSION_2
/*
* Avoids warning in Windows compiler when compiling with 8.3.1-.
*/
(Tcl_DriverBlockModeProc *)
#endif
TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2/8.4a2+) */
TCL_CHANNEL_VERSION_2, /* A v2 channel (8.3.2+) */
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 = {
static Tcl_ChannelType tlsChannelType1 = {
"tls", /* Type name. */
#ifdef TCL_CHANNEL_VERSION_2
/*
* Avoids warning in Windows compiler when compiling with 8.3.2+.
*/
(Tcl_ChannelTypeVersion)
#endif
TlsBlockModeProc, /* Set blocking/nonblocking mode.*/
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. */
};
#endif
Tcl_ChannelType *Tls_ChannelType()
{
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
return &tlsChannelType;
return &tlsChannelType2;
} else {
return &tlsChannelType1;
}
}
/*
*-------------------------------------------------------------------
*
* TlsBlockModeProc --
*
|
︙ | | |
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
|
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
|
-
-
-
-
+
+
+
+
-
+
|
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),
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
return 0;
} else {
return Tcl_SetChannelOption(statePtr->interp, Tls_GetParent(statePtr),
"-blocking", (mode == TCL_MODE_NONBLOCKING) ? "0" : "1");
#endif
}
}
/*
*-------------------------------------------------------------------
*
* TlsCloseProc --
*
|
︙ | | |
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
|
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
|
-
-
-
-
-
+
+
+
+
+
-
-
+
+
-
+
|
TlsCloseProc(ClientData instanceData, /* The socket to close. */
Tcl_Interp *interp) /* For error reporting - unused. */
{
State *statePtr = (State *) instanceData;
dprintf(stderr,"\nTlsCloseProc(0x%x)", statePtr);
#ifndef TCL_CHANNEL_VERSION_2
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
if (channelTypeVersion == TLS_CHANNEL_VERSION_1) {
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
TlsChannelHandler, (ClientData) statePtr);
Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
TlsChannelHandler, (ClientData) statePtr);
#endif
}
Tls_Clean(statePtr);
Tcl_EventuallyFree((ClientData)statePtr, Tls_Free);
return TCL_OK;
}
/*
|
︙ | | |
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
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
|
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
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
|
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
+
+
-
-
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
+
-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
-
+
-
+
|
*-------------------------------------------------------------------
*
* 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.
*
* Results:
* A standard Tcl result. The value of the specified option or a
* list of all options and their values is returned in the
* supplied DString.
*
* Side effects:
* None.
*
*-------------------------------------------------------------------
*/
static int
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. */
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;
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
Tcl_Channel downChan = Tls_GetParent(statePtr);
Tcl_DriverGetOptionProc *getOptionProc;
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
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;
size_t len = 0;
if (optionName != (char *) NULL) {
len = strlen(optionName);
}
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;
}
}
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;
return TCL_OK;
#endif
}
}
/*
*-------------------------------------------------------------------
*
* TlsWatchProc --
*
|
︙ | | |
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
|
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
|
-
-
+
+
-
+
-
-
-
-
-
-
-
+
+
+
+
+
+
+
-
+
-
-
+
+
-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
+
+
+
+
+
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
-
-
-
+
+
+
+
-
+
|
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;
if (channelTypeVersion == TLS_CHANNEL_VERSION_2) {
Tcl_Channel downChan;
statePtr->watchMask = mask;
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.
*/
/* 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);
downChan = Tls_GetParent(statePtr);
(Tcl_GetChannelType(downChan))
->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
(Tcl_GetChannelType(downChan))
->watchProc(Tcl_GetChannelInstanceData(downChan), mask);
/*
* Management of the internal timer.
*/
/*
* 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->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) {
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
if (statePtr->watchMask) {
/*
* Remove event handler to underlying channel, this could
* be because we are closing for real, or being "unstacked".
*/
Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
TlsChannelHandler, (ClientData) statePtr);
}
statePtr->watchMask = mask;
if (statePtr->watchMask) {
/*
* Setup active monitor for events on underlying Channel.
*/
Tcl_DeleteChannelHandler(Tls_GetParent(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, TlsChannelHandler, (ClientData) statePtr);
}
Tcl_CreateChannelHandler(Tls_GetParent(statePtr),
statePtr->watchMask, TlsChannelHandler,
(ClientData) statePtr);
}
#endif
}
}
/*
*-------------------------------------------------------------------
*
* TlsGetHandleProc --
*
|
︙ | | |
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
|
592
593
594
595
596
597
598
599
600
601
602
603
604
605
|
-
|
Tcl_DeleteTimerHandler(statePtr->timer);
statePtr->timer = (Tcl_TimerToken) NULL;
}
return mask;
}
#ifndef TCL_CHANNEL_VERSION_2
/*
*------------------------------------------------------*
*
* TlsChannelHandler --
*
* ------------------------------------------------*
* Handler called by Tcl as a result of
|
︙ | | |
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
|
671
672
673
674
675
676
677
678
679
680
681
682
683
684
|
-
|
* Data is waiting, flush it out in short time
*/
statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
TlsChannelHandlerTimer, (ClientData) statePtr);
}
Tcl_Release( (ClientData)statePtr);
}
#endif
/*
*------------------------------------------------------*
*
* TlsChannelHandlerTimer --
*
* ------------------------------------------------*
|
︙ | | |
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
|
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
|
-
-
-
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
-
+
-
-
+
|
}
}
Tcl_Channel
Tls_GetParent( statePtr )
State *statePtr;
{
#ifdef TCL_CHANNEL_VERSION_2
return Tcl_GetStackedChannel(statePtr->self);
#else
if (channelTypeVersion == TLS_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;
/* 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 <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;
}
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);
return Tcl_GetStackedChannel (self);
#endif
#endif
}
}
|
1
2
3
4
5
6
7
8
9
10
11
|
1
2
3
4
5
6
7
8
9
10
11
|
-
+
|
/*
* Copyright (C) 1997-2000 Matt Newman <matt@novadigm.com>
*
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsInt.h,v 1.5 2000/06/06 01:34:12 welch Exp $
* $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsInt.h,v 1.6 2000/08/15 00:02:08 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
|
︙ | | |
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
|
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
|
* This structure describes the per-instance state
* of an ssl channel.
*
* The SSL processing context is maintained here, in the ClientData
*/
typedef struct State {
Tcl_Channel self; /* this socket channel */
#if TCL_MAJOR_VERSION == 8 && TCL_MINOR_VERSION < 2
Tcl_Channel parent; /* underlying channel */
#endif
Tcl_TimerToken timer;
int flags; /* currently only CHANNEL_ASYNC */
int watchMask; /* current WatchProc mask */
int mode; /* current mode of parent channel */
Tcl_Interp *interp; /* interpreter in which this resides */
Tcl_Obj *callback; /* script called for tracing, verifying and errors */
int vflags; /* verify flags */
SSL *ssl; /* Struct for SSL processing */
SSL_CTX *ctx; /* SSL Context */
BIO *bio; /* Struct for SSL processing */
BIO *p_bio; /* Parent BIO (that is layered on Tcl_Channel) */
char *err;
} State;
/*
* The following definitions have to be usable for 8.0.x, 8.1.x, 8.2.x,
* 8.3.[01], 8.3.2 and beyond. The differences between these versions:
*
* 8.0-8.1: There is no support for these in TLS 1.4 (get 1.3). This
* was the version with the original patch.
*
* 8.2.0- Changed semantics for Tcl_StackChannel (Tcl_ReplaceChannel).
* 8.3.1: Check at runtime to switch the behaviour. The patch is part
* of the core from now on.
*
* 8.3.2+: Stacked channels rewritten for better behaviour in some
* situations (closing). Some new API's, semantic changes.
*
* The following magic was taken from Trf 2.1 (Kupries).
*/
#define TLS_CHANNEL_VERSION_1 0x1
#define TLS_CHANNEL_VERSION_2 0x2
extern int channelTypeVersion;
#ifdef USE_TCL_STUBS
#ifndef Tcl_StackChannel
/*
* The core we are compiling against is not patched, so supply the
* necesssary definitions here by ourselves. The form chosen for
* the procedure macros (reservedXXX) will notify us if the core
* does not have these reserved locations anymore.
*
* !! Synchronize the procedure indices in their definitions with
* the patch to tcl.decls, as they have to be the same.
*/
/* 281 */
typedef Tcl_Channel (tls_StackChannel) _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_ChannelType* typePtr,
ClientData instanceData,
int mask,
Tcl_Channel prevChan));
/* 282 */
typedef void (tls_UnstackChannel) _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Channel chan));
#define Tcl_StackChannel ((tls_StackChannel*) tclStubsPtr->reserved281)
#define Tcl_UnstackChannel ((tls_UnstackChannel*) tclStubsPtr->reserved282)
#endif /* Tcl_StackChannel */
#ifndef Tcl_GetStackedChannel
/*
* Separate definition, available in 8.2, but not 8.1 and before !
*/
/* 283 */
typedef Tcl_Channel (tls_GetStackedChannel) _ANSI_ARGS_((Tcl_Channel chan));
#define Tcl_GetStackedChannel ((tls_GetStackedChannel*) tclStubsPtr->reserved283)
#endif /* Tcl_GetStackedChannel */
#ifndef Tcl_WriteRaw
/*
* Core is older than 8.3.2. Supply the missing definitions for
* the new API's in 8.3.2.
*/
/* 394 */
typedef int (tls_ReadRaw) _ANSI_ARGS_((Tcl_Channel chan, char *dst,
int bytesToRead));
/* 395 */
typedef int (tls_WriteRaw) _ANSI_ARGS_((Tcl_Channel chan, char *src,
int srcLen));
/* 397 */
typedef int (tls_GetTopChannel) _ANSI_ARGS_((Tcl_Channel chan));
/*
* Generating code for accessing these parts of the stub table when
* compiling against a core older than 8.3.2 is a hassle because even
* the 'reservedXXX' fields of the structure are not defined yet. So
* we have to write up some macros hiding some very hackish pointer
* arithmetics to get at these fields. We assume that pointer to
* functions are always of the same size.
*/
#define STUB_BASE ((char*)(&(tclStubsPtr->tcl_UtfNcasecmp))) /* field 370 */
#define procPtrSize (sizeof (Tcl_DriverBlockModeProc *))
#define IDX(n) (((n)-370) * procPtrSize)
#define SLOT(n) (STUB_BASE + IDX(n))
#define Tcl_ReadRaw (*((tls_ReadRaw**) (SLOT(394))))
#define Tcl_WriteRaw (*((tls_WriteRaw**) (SLOT(395))))
#define Tcl_GetTopChannel (*((tls_GetTopChannel**)(SLOT(396))))
typedef struct TlsChannelTypeVersion_* TlsChannelTypeVersion;
#define TCL_CHANNEL_VERSION_2 ((TlsChannelTypeVersion) 0x2)
/*
* Required, easy emulation.
*/
#define Tcl_ChannelGetOptionProc(chanDriver) ((chanDriver)->getOptionProc)
#endif /* Tcl_WriteRaw */
#endif /* USE_TCL_STUBS */
/*
* Forward declarations
*/
EXTERN Tcl_ChannelType *Tls_ChannelType _ANSI_ARGS_((void));
EXTERN Tcl_Channel Tls_GetParent _ANSI_ARGS_((State *statePtr));
|
︙ | | |