Changes On Branch 1e0de94a93cfa0ab

Changes In Branch tls-1-3-io-rewrite Through [1e0de94a93] Excluding Merge-Ins

This is equivalent to a diff from c7d3de2764 to 1e0de94a93

2000-07-21
05:32
* tests/tlsIO.test: corrected various tests to be correct for TLS stacked channels (as opposed to the standard sockets the test suite was adopted from). Key differences are that TLS cannot operate in one process without all channels being non-blocking, or the handshake will block, and handshaking must be forced in some cases. Also, handshakes don't seem to complete unless the client has placed at least one byte for the server to read in the channel. * tests/remote.tcl: corrected the finding of tests certificates * tlsIO.c (TlsCloseProc): removed deleting of timer handler as that is handled by Tls_Clean. * tls.tcl (tls::_accept): corrected the internal _accept to trickle callback errors to the user. * Makefile.in: made the install-binaries target regenerate the pkgIndex.tcl correctly. The test target probably shouldn't screw it up, but this is to be on the safe side. check-in: 977988aed6 user: hobbs tags: tls-1-3-io-rewrite
2000-07-20
02:44
Use INSTALL_PROGRAM instead of INSTALL_DATA when installing libraries on hpux so that the libraries get execute permission. check-in: 2b4dc4cee0 user: wart tags: trunk
2000-07-17
23:17
* pkgIndex.tcl.in: * configure.in: updated version to 1.4 check-in: 1e0de94a93 user: hobbs tags: tls-1-3-io-rewrite
2000-07-14
04:10
* tests/tlsIO.test: enabled tests 2.10, 7.[1245] (there is no 3), which now pass. Added some comments to other failing tests. check-in: 7b1825af0d 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
2000-06-21
21:00
Changed name of test variable from TCLTESTARGS to TESTFLAGS check-in: b9eeeb6baa user: wart tags: trunk

Modified ChangeLog from [cd26bc6332] to [26e006953b].










































1
2
3
4
5
6
7
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+







2000-07-17  Jeff Hobbs  <[email protected]>

	* pkgIndex.tcl.in:
	* configure.in: updated version to 1.4

2000-07-13  Jeff Hobbs  <[email protected]>

	* tests/tlsIO.test: enabled tests 2.10, 7.[1245] (there is no 3),
	which now pass.  Added some comments to other failing tests.

2000-07-11  Jeff Hobbs  <[email protected]>

	* tlsIO.c: changed all the channel procs to start with Tls* for
	better parity when comparing with Transform channel procs.
	Rewrote TlsWatchProc, added TlsNotifyProc according to the new
	channel design, which also leaves TlsChannelHandler unused.

	* tlsBIO.c (BioCtrl): changed BIO_CTRL_FLUSH case to use
	Tcl_WriteRaw instead of Tcl_Flush (to operate on correct channel
	in the stack instead of starting at the top again).  Would
	otherwise cause a recursive stack bomb when implicit handshaking
	took effect.

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

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 configure.in from [b7f03645a1] to [f7106cacc4].

30
31
32
33
34
35
36
37

38
39
40
41
42
43
44
30
31
32
33
34
35
36

37
38
39
40
41
42
43
44







-
+







# like dots in # library names (Windows).  The VERSION variable is
# used on the other systems.
#--------------------------------------------------------------------

PACKAGE=tls

MAJOR_VERSION=1
MINOR_VERSION=3
MINOR_VERSION=4
PATCHLEVEL=

VERSION=${MAJOR_VERSION}.${MINOR_VERSION}${PATCHLEVEL}
NODOT_VERSION=${MAJOR_VERSION}${MINOR_VERSION}

AC_SUBST(PACKAGE)
AC_SUBST(VERSION)

Modified pkgIndex.tcl.in from [97e308791e] to [a7daa6d089].

1
2
3
4




5
6
7
8

9
1



2
3
4
5
6

7

8
9

-
-
-
+
+
+
+

-

-
+


# pkgIndex.tcl -
#    A new manually generated "pkgIndex.tcl" file for tls to replace the original
#    which didn't include the commands from "tls.tcl".
# pkgIndex.tcl - 
#
#    A new manually generated "pkgIndex.tcl" file for tls to
#    replace the original which didn't include the commands from "tls.tcl".
#
#    Al Borr 12/99, last revised Jan 11/00.

package ifneeded tls 1.3 "[list load [file join $dir @RELPATH@ @tls_LIB_FILE@] ] ; [list source [file join $dir tls.tcl] ]"
package ifneeded tls 1.4 "[list load [file join $dir @RELPATH@ @tls_LIB_FILE@] ] ; [list source [file join $dir tls.tcl] ]"

Modified tests/tlsIO.test from [321099ebe7] to [3c2ae49926].

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

14
15
16
17
18
19
20
1
2
3
4
5
6
7
8
9
10
11
12

13
14
15
16
17
18
19
20












-
+







# Commands tested in this file: socket.
#
# 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 $
# RCS: @(#) $Id: tlsIO.test,v 1.14.2.3 2000/07/14 04:10:23 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
309
310
311
312
313
314
315
316

317
318
319


320
321
322
323
324
325
326
309
310
311
312
313
314
315

316
317


318
319
320
321
322
323
324
325
326







-
+

-
-
+
+







    set f [open script w]
    puts $f {
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8829 \]"
    puts $f {
	proc accept {file addr port} {
	proc accept {sock addr port} {
            global x
            puts "[gets $file] $port"
            close $file
            puts "[gets $sock] $port"
            close $sock
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
348
349
350
351
352
353
354
355

356
357
358


359
360
361
362
363
364
365
348
349
350
351
352
353
354

355
356


357
358
359
360
361
362
363
364
365







-
+

-
-
+
+







    set f [open script w]
    puts $f {
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8830 \]"
    puts $f {
	proc accept {file addr port} {
	proc accept {sock addr port} {
            global x
            puts "[gets $file] $addr"
            close $file
            puts "[gets $sock] $addr"
            close $sock
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
385
386
387
388
389
390
391
392

393
394
395


396
397
398
399
400
401
402
385
386
387
388
389
390
391

392
393


394
395
396
397
398
399
400
401
402







-
+

-
-
+
+







    set f [open script w]
    puts $f {
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey -myaddr [info hostname] 8831 \]"
    puts $f {
	proc accept {file addr port} {
	proc accept {sock addr port} {
            global x
            puts "[gets $file]"
            close $file
            puts "[gets $sock]"
            close $sock
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
421
422
423
424
425
426
427
428

429
430
431


432
433
434
435
436
437
438
421
422
423
424
425
426
427

428
429


430
431
432
433
434
435
436
437
438







-
+

-
-
+
+







    set f [open script w]
    puts $f {
	package require tls
	set timer [after 2000 "set x done"]
    }
    puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8832 \]"
    puts $f {
	proc accept {file addr port} {
	proc accept {sock addr port} {
            global x
            puts "[gets $file]"
            close $file
            puts "[gets $sock]"
            close $sock
            set x done
	}
	puts ready
	vwait x
	after cancel $timer
	close $f
    }
574
575
576
577
578
579
580
581

582
583
584
585
586
587
588
574
575
576
577
578
579
580

581
582
583
584
585
586
587
588







-
+







    invoked from within
"eval ::socket $sopts"
    (procedure "tls::socket" line 62)
    invoked from within
"tls::socket -server accept 8828"
    (file "script" line 1)}}

test tlsIO-2.10 {close on accept, accepted socket lives} {socket knownBug} {
test tlsIO-2.10 {close on accept, accepted socket lives} {socket} {
    set done 0
    set timer [after 20000 "set done timed_out"]
    set ss [tls::socket -server accept -certfile $serverCert -cafile $caCert \
	-keyfile $serverKey 8830]
    proc accept {s a p} {
	global ss
	close $ss
601
602
603
604
605
606
607

608
609
610
611
612
613
614
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615







+








    vwait done
    after cancel $timer
    set done
} 1

test tlsIO-2.11 {detecting new data} {socket knownBug} {
    # HOBBS: hung pre-rewrite, hangs post-rewrite
    proc accept {s a p} {
	global sock
	set sock $s
	set f [open awb.log w]
	puts $f [catch {tls::handshake $sock} err]
	puts $f "err: $err"
	puts $f "[tls::status $sock]"
864
865
866
867
868
869
870

871
872
873
874
875
876
877
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879







+







	set x {htons problem, should be disallowed, are you running as SU?}
	close $msg
    }
    set x
} {couldn't open socket: not owner}

test tlsIO-6.1 {accept callback error} {unexplainedFailure socket stdio pcCrash} {
    # HOBBS: still fails post-rewrite
    removeFile script
    set f [open script w]
    puts $f {
    	package require tls
	gets stdin
	tls::socket 127.0.0.1 8848
    }
891
892
893
894
895
896
897
898

899
900
901
902
903
904
905
893
894
895
896
897
898
899

900
901
902
903
904
905
906
907







-
+







    close $s
    rename bgerror {}
    set x
} {{divide by zero}}

# bug report #5812 fconfigure doesn't return value for '-peername'

test tlsIO-7.1 {testing socket specific options} {knownBug socket stdio} {
test tlsIO-7.1 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	package require tls
    }
    puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820"
    puts $f {
925
926
927
928
929
930
931
932

933
934
935
936
937
938
939
927
928
929
930
931
932
933

934
935
936
937
938
939
940
941







-
+







    lappend l [string compare [lindex $p 0] 127.0.0.1]
    lappend l [string compare [lindex $p 2] 8820]
    lappend l [llength $p]
} {0 0 3}

# bug report #5812 fconfigure doesn't return value for '-sockname'

test tlsIO-7.2 {testing socket specific options} {knownBug socket stdio} {
test tlsIO-7.2 {testing socket specific options} {socket stdio} {
    removeFile script
    set f [open script w]
    puts $f {
	package require tls
    }
    puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8821"
    puts $f {
969
970
971
972
973
974
975
976

977
978
979
980
981
982
983
971
972
973
974
975
976
977

978
979
980
981
982
983
984
985







-
+







    close $s
    update
    llength $l
} 12

# bug report #5812 fconfigure doesn't return value for '-sockname'

test tlsIO-7.4 {testing socket specific options} {knownBug socket} {
test tlsIO-7.4 {testing socket specific options} {socket} {
    set s [tls::socket \
	-certfile $serverCert -cafile $caCert -keyfile $serverKey \
    	-server accept 8823]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
992
993
994
995
996
997
998
999

1000
1001
1002
1003
1004
1005
1006
994
995
996
997
998
999
1000

1001
1002
1003
1004
1005
1006
1007
1008







-
+







    close $s1
    set l ""
    lappend l [lindex $x 2] [llength $x]
} {8823 3}

# bug report #5812 fconfigure doesn't return value for '-sockname'

test tlsIO-7.5 {testing socket specific options} {knownBug socket unixOrPc} {
test tlsIO-7.5 {testing socket specific options} {socket unixOrPc} {
    set s [tls::socket \
	-certfile $serverCert -cafile $caCert -keyfile $serverKey \
    	-server accept 8829]
    proc accept {s a p} {
	global x
	set x [fconfigure $s -sockname]
	close $s
1014
1015
1016
1017
1018
1019
1020

1021
1022
1023
1024
1025
1026
1027
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030







+







    close $s
    close $s1
    set l ""
    lappend l [lindex $x 0] [lindex $x 2] [llength $x]
} {127.0.0.1 8829 3}

test tlsIO-8.1 {testing -async flag on sockets} {unexplainedHang socket} {
    # HOBBS: still fails post-rewrite
    # test seems to hang -- awb 6/2/2000
    # NOTE: This test may fail on some Solaris 2.4 systems. If it does,
    # check that you have these patches installed (using showrev -p):
    #
    # 101907-05, 101925-02, 101945-14, 101959-03, 101969-05, 101973-03,
    # 101977-03, 101981-02, 101985-01, 102001-03, 102003-01, 102007-01,
    # 102011-02, 102024-01, 102039-01, 102044-01, 102048-01, 102062-03,
1049
1050
1051
1052
1053
1054
1055

1056
1057
1058
1059
1060
1061
1062
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066







+







    set z [gets $s1]
    close $s
    close $s1
    set z
} bye

test tlsIO-9.1 {testing spurious events} {unexplainedHang socket} {
    # HOBBS: still fails post-rewrite
    # locks up 
    set len 0
    set spurious 0
    set done 0
    proc readlittle {s} {
	global spurious done len
	set l [read $s 1]
1087
1088
1089
1090
1091
1092
1093


1094
1095
1096
1097
1098
1099
1100
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106







+
+







    vwait done
    after cancel $timer
    close $s
    list $spurious $len
} {0 50}

test tlsIO-9.2 {testing async write, fileevents, flush on close} {socket} {
    # HOBBS: This hangs when I turn blocking on.
    #
    set firstblock ""
    for {set i 0} {$i < 5} {incr i} {set firstblock "a$firstblock$firstblock"}
    set secondblock ""
    for {set i 0} {$i < 16} {incr i} {
	set secondblock "b$secondblock$secondblock"
    }
    set l [tls::socket \
1132
1133
1134
1135
1136
1137
1138

1139
1140
1141
1142
1143
1144


1145
1146

1147
1148
1149
1150
1151
1152
1153
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149


1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161







+




-
-
+
+


+







	incr count [string length $l]
	if {[eof $s]} {
	    close $s
	    set done 1
	}
    }
    fileevent $s readable "readit $s"
    set done 0
    set timer [after 10000 "set done timed_out"]
    vwait done
    after cancel $timer
    close $l
    set count
} 65566
    list $count $done
} {65566 1}

test tlsIO-9.3 {testing EOF stickyness} {unexplainedHang socket} {
    # HOBBS: still fails post-rewrite
    # hangs
    proc count_to_eof {s} {
	global count done timer
	set l [gets $s]
	if {[eof $s]} {
	    incr count
	    if {$count > 9} {

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

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 <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tls.c,v 1.6 2000/06/06 01:34:11 welch Exp $
 * $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
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
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
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
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);
	    (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
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 [a47b0bf135].

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 <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2 2000/01/20 01:51:39 aborr Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsBIO.c,v 1.2.2.2 2000/07/12 01:54:26 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
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
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) {
179
180
181
182
183
184
185




186
187
188
189







190
191
192

193
194
195
196
197
198
199
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







+
+
+
+
-
-
-
-
+
+
+
+
+
+
+


-
+







    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
	if (Tcl_Flush( chan) == TCL_OK)
	    ret=1;
	else
	    ret=-1;
	    Tcl_Flush( chan) == TCL_OK
#endif
	    ) {
	    ret = 1;
	} else {
	    ret = -1;
	}
	break;
    default:
	ret=0;
	ret = 0;
	break;
    }
    return(ret);
}

static int
BioNew	(bio)

Modified tlsIO.c from [83d2c33ca1] to [0145d832d0].

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 <[email protected]>
 *
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7 2000/06/05 18:09:54 welch Exp $
 * $Header: /home/rkeene/tmp/cvs2fossil/../tcltls/tls/tls/tlsIO.c,v 1.7.2.2 2000/07/12 01:54:26 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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
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
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
28
29
30
31
32
33
34













35
36
37
38
39
40
41
42
43
44
45
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
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







-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+





-
+


+
+
+
+
+
+
+
+
+
+
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+


-
-
-
+
+
+

+









-
+













-
+











+
+
+


+





-
+
















-
+




-
+





-
+

-
-
+
+













-
+
















-
+







 * Local Defines
 */

/*
 * Forward declarations
 */

static int	BlockModeProc _ANSI_ARGS_((ClientData instanceData, int mode));
static int	CloseProc _ANSI_ARGS_ ((ClientData instanceData, Tcl_Interp *interp));
static int	InputProc _ANSI_ARGS_((ClientData instanceData,
			    char *buf, int bufSize, int *errorCodePtr));
static int	OutputProc _ANSI_ARGS_((ClientData instanceData,
			    char *buf, int toWrite, int *errorCodePtr));
static int	GetOptionProc _ANSI_ARGS_ ((ClientData instanceData,
			    Tcl_Interp *interp, char *optionName, Tcl_DString *dsPtr));
static void	WatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
static int	GetHandleProc _ANSI_ARGS_ ((ClientData instanceData,
			    int direction, ClientData *handlePtr));
static void	ChannelHandler _ANSI_ARGS_ ((ClientData clientData, int mask));
static void	ChannelHandlerTimer _ANSI_ARGS_ ((ClientData clientData));
static int	TlsBlockModeProc _ANSI_ARGS_((ClientData instanceData,
			int mode));
static int	TlsCloseProc _ANSI_ARGS_ ((ClientData instanceData,
			Tcl_Interp *interp));
static int	TlsInputProc _ANSI_ARGS_((ClientData instanceData,
			char *buf, int bufSize, int *errorCodePtr));
static int	TlsOutputProc _ANSI_ARGS_((ClientData instanceData,
			char *buf, int toWrite, int *errorCodePtr));
static int	TlsGetOptionProc _ANSI_ARGS_ ((ClientData instanceData,
			Tcl_Interp *interp, char *optionName,
			Tcl_DString *dsPtr));
static void	TlsWatchProc _ANSI_ARGS_((ClientData instanceData, int mask));
static int	TlsGetHandleProc _ANSI_ARGS_ ((ClientData instanceData,
			int direction, ClientData *handlePtr));
static int	TlsNotifyProc _ANSI_ARGS_ ((ClientData instanceData,
			int mask));
static void	TlsChannelHandler _ANSI_ARGS_ ((ClientData clientData,
			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 = {
    "tls",		/* Type name. */
    TCL_CHANNEL_VERSION_2,	/* A NG channel */
    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. */
    BlockModeProc,	/* Set blocking/nonblocking mode.*/
    CloseProc,		/* Close proc. */
    InputProc,		/* Input proc. */
    OutputProc,		/* Output proc. */
    TlsBlockModeProc,	/* Set blocking/nonblocking mode.*/
    NULL,		/* FlushProc. */
    TlsNotifyProc,	/* handlerProc. */
};
#else
static Tcl_ChannelType tlsChannelType = {
    "tls",		/* Type name. */
    TlsBlockModeProc,	/* Set blocking/nonblocking mode.*/
    TlsCloseProc,		/* Close proc. */
    TlsInputProc,		/* Input proc. */
    TlsOutputProc,		/* Output proc. */
    NULL,		/* Seek proc. */
    NULL,		/* Set option proc. */
    GetOptionProc,	/* Get option proc. */
    WatchProc,		/* Initialize notifier. */
    GetHandleProc,	/* Get file handle out of channel. */
    TlsGetOptionProc,	/* Get option proc. */
    TlsWatchProc,		/* Initialize notifier. */
    TlsGetHandleProc,	/* Get file handle out of channel. */
};
#endif

Tcl_ChannelType *Tls_ChannelType()
{
    return &tlsChannelType;
}

/*
 *-------------------------------------------------------------------
 *
 * BlockModeProc --
 * TlsBlockModeProc --
 *
 *	This procedure is invoked by the generic IO level
 *       to set blocking and nonblocking modes
 * Results:
 *	0 if successful, errno when failed.
 *
 * Side effects:
 *	Sets the device into blocking or nonblocking mode.
 *
 *-------------------------------------------------------------------
 */

static int
BlockModeProc(ClientData instanceData,	/* Socket state. */
TlsBlockModeProc(ClientData instanceData,	/* Socket state. */
                 int mode)			/* The mode to set. Can be one of
						* TCL_MODE_BLOCKING or
						* TCL_MODE_NONBLOCKING. */
{
    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 --
 * TlsCloseProc --
 *
 *	This procedure is invoked by the generic IO level to perform
 *	channel-type-specific cleanup when a SSL socket based channel
 *	is closed.
 *
 *	Note: we leave the underlying socket alone, is this right?
 *
 * Results:
 *	0 if successful, the value of Tcl_GetErrno() if failed.
 *
 * Side effects:
 *	Closes the socket of the channel.
 *
 *-------------------------------------------------------------------
 */
static int
CloseProc(ClientData instanceData,	/* The socket to close. */
TlsCloseProc(ClientData instanceData,	/* The socket to close. */
             Tcl_Interp *interp)	/* For error reporting - unused. */
{
    State *statePtr = (State *) instanceData;

    dprintf(stderr,"\nCloseProc(0x%x)", statePtr);
    dprintf(stderr,"\nTlsCloseProc(0x%x)", statePtr);

    /*
     * Remove event handler to underlying channel, this could
     * be because we are closing for real, or being "unstacked".
     */

#ifndef TCL_CHANNEL_VERSION_2
    Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
	ChannelHandler, (ClientData) statePtr);

	TlsChannelHandler, (ClientData) statePtr);
#endif
    if (statePtr->timer != (Tcl_TimerToken)NULL) {
	Tcl_DeleteTimerHandler (statePtr->timer);
	statePtr->timer = (Tcl_TimerToken)NULL;
    }

    Tls_Clean(statePtr);
    Tcl_EventuallyFree( (ClientData)statePtr, Tls_Free);
    return TCL_OK;
}

/*
 *-------------------------------------------------------------------
 *
 * InputProc --
 * TlsInputProc --
 *
 *	This procedure is invoked by the generic IO level
 *       to read input from a SSL socket based channel.
 *
 * Results:
 *	The number of bytes read is returned or -1 on error. An output
 *	argument contains the POSIX error code on error, or zero if no
 *	error occurred.
 *
 * Side effects:
 *	Reads input from the input device of the channel.
 *
 *-------------------------------------------------------------------
 */

static int
InputProc(ClientData instanceData,	/* Socket state. */
TlsInputProc(ClientData instanceData,	/* Socket state. */
             char *buf,			/* Where to store data read. */
             int bufSize,		/* How much space is available
                                         * in the buffer? */
             int *errorCodePtr)		/* Where to store error code. */
{
    State *statePtr = (State *) instanceData;
    int bytesRead;			/* How many bytes were read? */
217
218
219
220
221
222
223
224

225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240

241
242
243
244
245
246
247
245
246
247
248
249
250
251

252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267

268
269
270
271
272
273
274
275







-
+















-
+







    dprintf(stderr, "\nInput(%d) -> %d [%d]", bufSize, bytesRead, *errorCodePtr);
    return bytesRead;
}

/*
 *-------------------------------------------------------------------
 *
 * OutputProc --
 * TlsOutputProc --
 *
 *	This procedure is invoked by the generic IO level
 *       to write output to a SSL socket based channel.
 *
 * Results:
 *	The number of bytes written is returned. An output argument is
 *	set to a POSIX error code if an error occurred, or zero.
 *
 * Side effects:
 *	Writes output on the output device of the channel.
 *
 *-------------------------------------------------------------------
 */

static int
OutputProc(ClientData instanceData,	/* Socket state. */
TlsOutputProc(ClientData instanceData,	/* Socket state. */
              char *buf,			/* The data buffer. */
              int toWrite,		/* How many bytes to write? */
              int *errorCodePtr)	/* Where to store error code. */
{
    State *statePtr = (State *) instanceData;
    int written, err;

306
307
308
309
310
311
312
313

314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331

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















































436
437
438
439

440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460



461
462
463
464
465
466
467
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
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
436
437
438
439
440
441
442
443
444
445
446
447
448
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
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570

571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589



590
591
592
593
594
595
596
597
598
599







-
+

















-
+








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




















+





-
+














-
+






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










-
+








-
+

+





-
+













-
+





-
+


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



-
+


















-
-
-
+
+
+







    dprintf(stderr, "\nOutput(%d) -> %d", toWrite, written);
    return written;
}

/*
 *-------------------------------------------------------------------
 *
 * GetOptionProc --
 * 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
GetOptionProc(ClientData instanceData,	/* Socket state. */
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. */
{
#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 --
 * TlsWatchProc --
 *
 *	Initialize the notifier to watch Tcl_Files from this channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	Sets up the notifier so that a future event on the channel
 *	will be seen by Tcl.
 *
 *-------------------------------------------------------------------
 */

static void
WatchProc(ClientData instanceData,	/* The socket state. */
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;

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

    downChan = Tls_GetParent(statePtr);

    (Tcl_GetChannelType(downChan))
	->watchProc(Tcl_GetChannelInstanceData(downChan), mask);

    /*
     * 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->watchMask) {
	/*
	 * Remove event handler to underlying channel, this could
	 * be because we are closing for real, or being "unstacked".
	 */

	Tcl_DeleteChannelHandler(Tls_GetParent(statePtr),
		ChannelHandler, (ClientData) 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, ChannelHandler, (ClientData) statePtr);
		statePtr->watchMask, TlsChannelHandler, (ClientData) statePtr);
    }
#endif
}

/*
 *-------------------------------------------------------------------
 *
 * GetHandleProc --
 * TlsGetHandleProc --
 *
 *	Called from Tcl_GetChannelFile to retrieve o/s file handler
 *	from the SSL socket based channel.
 *
 * Results:
 *	The appropriate Tcl_File or NULL if not present. 
 *
 * Side effects:
 *	None.
 *
 *-------------------------------------------------------------------
 */
static int
GetHandleProc(ClientData instanceData,	/* The socket state. */
TlsGetHandleProc(ClientData instanceData,	/* The socket state. */
                 int direction,		/* Which Tcl_File to retrieve? */
                 ClientData *handlePtr)	/* Where to store the handle.  */
{
    State *statePtr = (State *) instanceData;

    return Tcl_GetChannelHandle (Tls_GetParent(statePtr), direction, handlePtr);
    return Tcl_GetChannelHandle(Tls_GetParent(statePtr), direction, handlePtr);
}

/*
 *-------------------------------------------------------------------
 *
 * TlsNotifyProc --
 *
 *	Handler called by Tcl to inform us of activity
 *	on the underlying channel.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	May process the incoming event by itself.
 *
 *-------------------------------------------------------------------
 */

static int
TlsNotifyProc(instanceData, mask)
    ClientData	   instanceData; /* The state of the notified transformation */
    int		   mask;       /* The mask of occuring events */
{
    State *statePtr = (State *) instanceData;

    /*
     * An event occured in the underlying channel.  This
     * transformation doesn't process such events thus returns the
     * incoming mask unchanged.
     */

    if (statePtr->timer != (Tcl_TimerToken) NULL) {
	/*
	 * Delete an existing timer. It was not fired, yet we are
	 * here, so the channel below generated such an event and we
	 * don't have to. The renewal of the interest after the
	 * execution of channel handlers will eventually cause us to
	 * recreate the timer (in WatchProc).
	 */

	Tcl_DeleteTimerHandler(statePtr->timer);
	statePtr->timer = (Tcl_TimerToken) NULL;
    }

    return mask;
}

#ifndef TCL_CHANNEL_VERSION_2
/*
 *------------------------------------------------------*
 *
 *      ChannelHandler --
 *      TlsChannelHandler --
 *
 *      ------------------------------------------------*
 *      Handler called by Tcl as a result of
 *      Tcl_CreateChannelHandler - to inform us of activity
 *      on the underlying channel.
 *      ------------------------------------------------*
 *
 *      Sideeffects:
 *              May generate subsequent calls to
 *              Tcl_NotifyChannel.
 *
 *      Result:
 *              None.
 *
 *------------------------------------------------------*
 */

static void
ChannelHandler (clientData, mask)
ClientData     clientData;
int            mask;
TlsChannelHandler (clientData, mask)
    ClientData     clientData;
    int            mask;
{
    State *statePtr = (State *) clientData;

dprintf(stderr, "HANDLER(0x%x)\n", mask);
    Tcl_Preserve( (ClientData)statePtr);

    if (mask & TCL_READABLE) {
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
532
533
534
535
536

537
538
539
540
541
542
543
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

669
670
671
672
673
674
675
676







-
+




-
+



+




-
+







-
+








-
+







    
    Tcl_NotifyChannel(statePtr->self, mask);
    
    if (statePtr->timer != (Tcl_TimerToken)NULL) {
	Tcl_DeleteTimerHandler(statePtr->timer);
	statePtr->timer = (Tcl_TimerToken)NULL;
    }
    if ((mask & TCL_READABLE) && Tcl_InputBuffered (statePtr->self) > 0) {
    if ((mask & TCL_READABLE) && Tcl_InputBuffered(statePtr->self) > 0) {
	/*
	 * Data is waiting, flush it out in short time
	 */
	statePtr->timer = Tcl_CreateTimerHandler(TLS_TCL_DELAY,
		ChannelHandlerTimer, (ClientData) statePtr);
		TlsChannelHandlerTimer, (ClientData) statePtr);
    }
    Tcl_Release( (ClientData)statePtr);
}
#endif

/*
 *------------------------------------------------------*
 *
 *	ChannelHandlerTimer --
 *	TlsChannelHandlerTimer --
 *
 *	------------------------------------------------*
 *	Called by the notifier (-> timer) to flush out
 *	information waiting in channel buffers.
 *	------------------------------------------------*
 *
 *	Sideeffects:
 *		As of 'ChannelHandler'.
 *		As of 'TlsChannelHandler'.
 *
 *	Result:
 *		None.
 *
 *------------------------------------------------------*
 */

static void
ChannelHandlerTimer (clientData)
TlsChannelHandlerTimer (clientData)
ClientData clientData; /* Transformation to query */
{
    State *statePtr = (State *) clientData;
    int mask = 0;

    statePtr->timer = (Tcl_TimerToken) NULL;

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
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
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







+
+
+


















-
-
+
+

-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

-
+

+

    }
}

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;
    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;
  }
    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);
    return Tcl_GetStackedChannel (self);
#endif
#endif
}