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.2.4 2000/07/21 05:32:57 hobbs Exp $
# RCS: @(#) $Id: tlsIO.test,v 1.14.2.5 2000/07/26 23:11: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
|
︙ | | |
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
|
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
|
-
+
+
+
+
|
fconfigure $sock -blocking 1
close $s2
close $s
close $sock
set result
} {a:one b: c:two}
test tlsIO-2.12 {tcp connection; no certificates specified} {socket stdio pcCrash} {
test tlsIO-2.12 {tcp connection; no certificates specified} \
{socket stdio unixOnly} {
# There is a debug assertion on Windows/SSL that causes a crash when the
# certificate isn't specified.
removeFile script
set f [open script w]
puts $f {
package require tls
set timer [after 2000 "set x timed_out"]
set f [tls::socket -server accept 8828]
proc accept {file addr port} {
|
︙ | | |
793
794
795
796
797
798
799
800
801
802
803
804
805
806
|
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
|
+
|
close $s3
lappend x [gets $f]
close $f
set x
} {ready done}
test tlsIO-4.1 {server with several clients} {socket stdio} {
# have seen intermittent hangs on Windows
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 \]"
|
︙ | | |
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
|
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
|
-
-
-
+
-
-
-
-
-
-
+
-
-
-
-
+
-
-
-
+
-
+
+
-
-
+
-
+
|
if {![catch {tls::socket -server dodo 21} msg]} {
set x {htons problem, should be disallowed, are you running as SU?}
close $msg
}
set x
} {couldn't open socket: not owner}
if {0} {
package require tls
test tlsIO-6.1 {accept callback error} {socket stdio} {
proc accept {s a p} {
puts [info level 0]
expr 10 / 0
}
set s [tls::socket -server accept 8848]
# There is a debug assertion on Windows/SSL that causes a crash when the
proc bgerror args { puts "bgerror: $args" }
set s [tls::socket zamora.scriptics.com 8848]
}
# certificate isn't specified.
test tlsIO-6.1 {accept callback error} { 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
}
puts $f [list tls::socket -cafile $caCert 127.0.0.1 8848]
close $f
set f [open "|[list $::tcltest::tcltest script]" r+]
proc bgerror args {
global x
set x $args
}
proc accept {s a p} {expr 10 / 0}
set s [tls::socket -server accept 8848]
set s [tls::socket -server accept \
-certfile $serverCert -cafile $caCert -keyfile $serverKey 8848]
puts $f hello
close $f
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
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} {socket stdio} {
removeFile script
set f [open script w]
puts $f {
package require tls
}
puts $f [list tls::socket -server accept \
puts $f "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 8820"
-certfile $serverCert -cafile $caCert -keyfile $serverKey 8820]
puts $f {
proc accept args {
global x
set x done
}
puts ready
set timer [after 10000 "set x timed_out"]
|
︙ | | |
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
|
963
964
965
966
967
968
969
970
971
972
973
974
975
976
|
-
-
|
close $f
set l ""
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} {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"
|
︙ | | |
1841
1842
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852
1853
1854
1855
|
1831
1832
1833
1834
1835
1836
1837
1838
1839
1840
1841
1842
1843
1844
1845
1846
|
-
+
+
|
vwait x
if {!$failed} {
vwait failed
}
set x
} {client socket was not inherited}
test tlsIO-12.3 {testing inheritance of accepted sockets} {socket exec} {
test tlsIO-12.3 {testing inheritance of accepted sockets} \
{socket exec unixOnly} {
makeFile {} script1
makeFile {} script2
set f [open script1 w]
puts $f {
after 10000 exit
vwait forever
|
︙ | | |