Diff
Bounty program for improvements to Tcl and certain Tcl packages.

Differences From Artifact [2e3a6ecd88]:

To Artifact [e303767c20]:


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

    proc accept {s a p} {
	puts [info level 0]
	expr 10 / 0
    }
    set s [tls::socket -server accept 8848]

    proc bgerror args { puts "bgerror: $args" }
    set s [tls::socket zamora.scriptics.com 8848]
}

test tlsIO-6.1 {accept callback error} { socket stdio pcCrash} {
test tlsIO-6.1 {accept callback error} {socket stdio} {
    # HOBBS: still fails post-rewrite
    # 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
	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