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.8 2000/06/03 02:30:03 awb Exp $
# RCS: @(#) $Id: tlsIo.test,v 1.9 2000/06/03 03:00:22 awb 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
|
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
|
1680
1681
1682
1683
1684
1685
1686
1687
1688
1689
1690
1691
1692
1693
1694
1695
1696
|
-
+
+
+
|
exec $::tcltest::tcltest script2 &
after 5000 { set ok_to_proceed 1 }
vwait ok_to_proceed
# If we can still connect to the server, the socket got inherited.
if {[catch {tls::socket 127.0.0.1 2828} msg]} {
if {[catch {tls::socket \
-certfile $clientCert -cafile $caCert -keyfile $clientKey \
127.0.0.1 2828} msg]} {
set x {server socket was not inherited}
} else {
close $msg
set x {server socket was inherited}
}
removeFile script1
|
1716
1717
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
|
1718
1719
1720
1721
1722
1723
1724
1725
1726
1727
1728
1729
1730
1731
1732
1733
1734
1735
1736
1737
1738
1739
1740
1741
1742
1743
1744
1745
1746
|
-
+
-
+
+
+
|
# client socket, the socket will still be open.
set f [open script2 w]
puts $f [list set tcltest $::tcltest::tcltest]
puts $f {
package require tls
}
puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 127.0.0.1 2829 \]"
puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 2829 \]"
puts $f {
exec $::tcltest::tcltest script1 &
puts $f testing
flush $f
after 1000 exit
vwait forever
}
close $f
# Create the server socket
set server [tls::socket -server accept 2829]
set server [tls::socket \
-certfile $serverCert -cafile $caCert -keyfile $serverKey \
-server accept 2829]
proc accept { file host port } {
# When the client connects, establish the read handler
global server
close $server
fileevent $file readable [list getdata $file]
fconfigure $file -buffering line -blocking 0
|