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
# 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 $

# 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











|







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



    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} {






|
>
>
>







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 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
    close $s3
    lappend x [gets $f]
    close $f
    set x
} {ready done}

test tlsIO-4.1 {server with several clients} {socket stdio} {

    removeFile script
    set f [open script w]
    puts $f {
    	package require tls
	gets stdin
    }
    puts $f "set s \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 8828 \]"






>







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
    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} {
    # 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
    }

    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]

    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 "tls::socket -server accept -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"]






<
<
<
<
<
<
<
<
<
<
<
<
<
|
<
>
>





<

>







|
>










<
<






>
|







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}














test tlsIO-6.1 {accept callback error} {socket stdio} {

    # 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

    }
    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 \
	    -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}}



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






<
<







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}



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
    vwait x
    if {!$failed} {
	vwait failed
    }
    set x
} {client socket was not inherited}

test tlsIO-12.3 {testing inheritance of accepted sockets} {socket exec} {

    makeFile {} script1
    makeFile {} script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever






|
>







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 unixOnly} {
    makeFile {} script1
    makeFile {} script2

    set f [open script1 w]
    puts $f {
	after 10000 exit
	vwait forever