DELETED tests/tlsIo.test Index: tests/tlsIo.test ================================================================== --- tests/tlsIo.test +++ /dev/null @@ -1,2012 +0,0 @@ -# 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.13 2000/06/05 20:22:34 aborr 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 -# can start the remote server on any machine reachable from the machine on -# which you want to run the socket tests, by issuing: -# -# tcltest remote.tcl -port 2048 # Or choose another port number. -# -# If the machine you are running the remote server on has several IP -# interfaces, you can choose which interface the server listens on for -# connections by specifying the -address command line flag, so: -# -# tcltest remote.tcl -address your.machine.com -# -# These options can also be set by environment variables. On Unix, you can -# type these commands to the shell from which the remote server is started: -# -# shell% setenv serverPort 2048 -# shell% setenv serverAddress your.machine.com -# -# and subsequently you can start the remote server with: -# -# tcltest remote.tcl -# -# to have it listen on port 2048 on the interface your.machine.com. -# -# When the server starts, it prints out a detailed message containing its -# configuration information, and it will block until killed with a Ctrl-C. -# Once the remote server exists, you can run the tests in socket.test with -# the server by setting two Tcl variables: -# -# % set remoteServerIP -# % set remoteServerPort 2048 -# -# These variables are also settable from the environment. On Unix, you can: -# -# shell% setenv remoteServerIP machine.where.server.runs -# shell% senetv remoteServerPort 2048 -# -# The preamble of the socket.test file checks to see if the variables are set -# either in Tcl or in the environment; if they are, it attempts to connect to -# the server. If the connection is successful, the tests using the remote -# server will be performed; otherwise, it will attempt to start the remote -# server (via exec) on platforms that support this, on the local host, -# listening at port 2048. If all fails, a message is printed and the tests -# using the remote server are not performed. - -if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest - namespace import -force ::tcltest::* -} - -# Load the tls package -package require tls - -set serverCert [file join $::tcltest::testsDirectory certs server.pem] -set clientCert [file join $::tcltest::testsDirectory certs client.pem] -set caCert [file join $::tcltest::testsDirectory certs cacert.pem] -set serverKey [file join $::tcltest::testsDirectory certs skey.pem] -set clientKey [file join $::tcltest::testsDirectory certs ckey.pem] - -# Some tests require the testthread command - -set ::tcltest::testConstraints(testthread) \ - [expr {[info commands testthread] != {}}] - -# -# If remoteServerIP or remoteServerPort are not set, check in the -# environment variables for externally set values. -# - -if {![info exists remoteServerIP]} { - if {[info exists env(remoteServerIP)]} { - set remoteServerIP $env(remoteServerIP) - } -} -if {![info exists remoteServerPort]} { - if {[info exists env(remoteServerIP)]} { - set remoteServerPort $env(remoteServerPort) - } else { - if {[info exists remoteServerIP]} { - set remoteServerPort 2048 - } - } -} - -# -# Check if we're supposed to do tests against the remote server -# - -set doTestsWithRemoteServer 1 -if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { - set remoteServerIP 127.0.0.1 -} -if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { - set remoteServerPort 2048 -} - -# Attempt to connect to a remote server if one is already running. If it -# is not running or for some other reason the connect fails, attempt to -# start the remote server on the local host listening on port 2048. This -# is only done on platforms that support exec (i.e. not on the Mac). On -# platforms that do not support exec, the remote server must be started -# by the user before running the tests. - -set remoteProcChan "" -set commandSocket "" -if {$doTestsWithRemoteServer} { - catch {close $commandSocket} - if {[catch {set commandSocket [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP \ - $remoteServerPort]}] != 0} { - if {[info commands exec] == ""} { - set noRemoteTestReason "can't exec" - set doTestsWithRemoteServer 0 - } else { - set remoteServerIP 127.0.0.1 - set remoteFile [file join [pwd] remote.tcl] - if {[catch {set remoteProcChan \ - [open "|[list $::tcltest::tcltest $remoteFile \ - -serverIsSilent \ - -port $remoteServerPort \ - -address $remoteServerIP]" \ - w+]} \ - msg] == 0} { - after 1000 - if {[catch {set commandSocket [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP \ - $remoteServerPort]} msg] == 0} { - fconfigure $commandSocket -translation crlf -buffering line - } else { - set noRemoteTestReason $msg - set doTestsWithRemoteServer 0 - } - } else { - set noRemoteTestReason "$msg $::tcltest::tcltest" - set doTestsWithRemoteServer 0 - } - } - } else { - fconfigure $commandSocket -translation crlf -buffering line - } -} - -# Some tests are run only if we are doing testing against a remote server. -set ::tcltest::testConstraints(doTestsWithRemoteServer) $doTestsWithRemoteServer -if {$doTestsWithRemoteServer == 0} { - if {[string first s $::tcltest::verbose] != -1} { - puts "Skipping tests with remote server. See tests/socket.test for" - puts "information on how to run remote server." - puts "Reason for not doing remote tests: $noRemoteTestReason" - } -} - -# -# If we do the tests, define a command to send a command to the -# remote server. -# - -if {$doTestsWithRemoteServer == 1} { - proc sendCommand {c} { - global commandSocket - - if {[eof $commandSocket]} { - error "remote server disappeared" - } - - if {[catch {puts $commandSocket $c} msg]} { - error "remote server disappaered: $msg" - } - if {[catch {puts $commandSocket "--Marker--Marker--Marker--"} msg]} { - error "remote server disappeared: $msg" - } - - set resp "" - while {1} { - set line [gets $commandSocket] - if {[eof $commandSocket]} { - error "remote server disappeared" - } - if {[string compare $line "--Marker--Marker--Marker--"] == 0} { - if {[string compare [lindex $resp 0] error] == 0} { - error [lindex $resp 1] - } else { - return [lindex $resp 1] - } - } else { - append resp $line "\n" - } - } - } -} - -test tlsIo-1.1 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIo-1.2 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server foo} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIo-1.3 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myaddr} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.4 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myaddr 127.0.0.1} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.5 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myport} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.6 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myport xxxx} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.7 {arg parsing for socket command} {socket} { - list [catch {tls::socket -myport 2522} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.8 {arg parsing for socket command} {socket} { - list [catch {tls::socket -froboz} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.9 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server foo -myport 2521 3333} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIo-1.10 {arg parsing for socket command} {socket} { - list [catch {tls::socket host 2528 -junk} msg] $msg -} {1 {wrong # args: should be "tls::socket ?options? host port"}} - -test tlsIo-1.11 {arg parsing for socket command} {socket} { - list [catch {tls::socket -server callback 2520 --} msg] $msg -} {1 {wrong # args: should be "tls::socket -server command ?options? port"}} - -test tlsIo-1.12 {arg parsing for socket command} {socket} { - list [catch {tls::socket foo badport} msg] $msg -} {1 {expected integer but got "badport"}} - -test tlsIo-2.1 {tcp connection} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - package require tls - set timer [after 2000 "set x timed_out"] - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2828 \]" - puts $f { - proc accept {file addr port} { - global x - set x done - close $file - } - puts ready - vwait x - after cancel $timer - close $f - puts $x - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2828} msg]} { - set x $msg - } else { - lappend x [gets $f] - close $msg - } - lappend x [gets $f] - close $f - set x -} {ready done {}} - -if [info exists port] { - incr port -} else { - set port [expr 2048 + [pid]%1024] -} - -test tlsIo-2.2 {tcp connection with client port specified} {socket stdio} { - removeFile script - 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 2829 \]" - puts $f { - proc accept {file addr port} { - global x - puts "[gets $file] $port" - close $file - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - global port - if {[catch {tls::socket -myport $port \ - -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2829} sock]} { - set x $sock - catch {close [tls::socket 127.0.0.1 2829]} - } else { - puts $sock hello - flush $sock - lappend x [gets $f] - close $sock - } - close $f - set x -} [list ready "hello $port"] - -test tlsIo-2.3 {tcp connection with client interface specified} {socket stdio} { - removeFile script - 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 2830 \]" - puts $f { - proc accept {file addr port} { - global x - puts "[gets $file] $addr" - close $file - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -myaddr 127.0.0.1 \ - -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2830} sock]} { - set x $sock - } else { - puts $sock hello - catch {flush $sock} - lappend x [gets $f] - close $sock - } - close $f - set x -} {ready {hello 127.0.0.1}} - -test tlsIo-2.4 {tcp connection with server interface specified} {socket stdio} { - removeFile script - 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] 2831 \]" - puts $f { - proc accept {file addr port} { - global x - puts "[gets $file]" - close $file - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey [info hostname] 2831} sock]} { - set x $sock - } else { - puts $sock hello - flush $sock - lappend x [gets $f] - close $sock - } - close $f - set x -} {ready hello} - -test tlsIo-2.5 {tcp connection with redundant server port} {socket stdio} { - removeFile script - 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 2832 \]" - puts $f { - proc accept {file addr port} { - global x - puts "[gets $file]" - close $file - set x done - } - puts ready - vwait x - after cancel $timer - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2832} sock]} { - set x $sock - } else { - puts $sock hello - flush $sock - lappend x [gets $f] - close $sock - } - close $f - set x -} {ready hello} -test tlsIo-2.6 {tcp connection} {socket} { - set status ok - if {![catch {set sock [tls::socket 127.0.0.1 2833]}]} { - if {![catch {gets $sock}]} { - set status broken - } - close $sock - } - set status -} ok - -test tlsIo-2.7 {echo server, one line} {socket stdio} { - removeFile script - 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 2834 \]" - puts $f { - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -translation lf -buffering line - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - puts $s $l - } - } - puts ready - vwait x - after cancel $timer - close $f - puts done - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2834] - fconfigure $s -buffering line -translation lf - puts $s "hello abcdefghijklmnop" - after 1000 - set x [gets $s] - close $s - set y [gets $f] - close $f - list $x $y -} {{hello abcdefghijklmnop} done} - -test tlsIo-2.8 {echo server, loop 50 times, single connection} {socket stdio} { - set f [open script w] - puts $f { - package require tls - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2835 \]" - puts $f { - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } - proc echo {s} { - global i - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - incr i - puts $s $l - } - } - set i 0 - puts ready - set timer [after 20000 "set x done"] - vwait x - after cancel $timer - close $f - puts "done $i" - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2835] - fconfigure $s -buffering line - catch { - for {set x 0} {$x < 50} {incr x} { - puts $s "hello abcdefghijklmnop" - gets $s - } - } - close $s - catch {set x [gets $f]} - close $f - set x -} {done 50} - -test tlsIo-2.9 {socket conflict} {socket stdio} { - set s [tls::socket -server accept 2828] - removeFile script - set f [open script w] - puts -nonewline $f {package require tls; tls::socket -server accept 2828} - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - after 100 - set x [list [catch {close $f} msg] $msg] - close $s - set x -} {1 {couldn't open socket: address already in use - while executing -"::socket -server {tls::_accept {-server 1} accept} 2828" - ("eval" body line 1) - invoked from within -"eval ::socket $sopts" - (procedure "tls::socket" line 62) - invoked from within -"tls::socket -server accept 2828" - (file "script" line 1)}} - -test tlsIo-2.10 {close on accept, accepted socket lives} {socket knownBug} { - set done 0 - set timer [after 20000 "set done timed_out"] - set ss [tls::socket -server accept -certfile $serverCert -cafile $caCert \ - -keyfile $serverKey 2830] - proc accept {s a p} { - global ss - close $ss - fileevent $s readable "readit $s" - fconfigure $s -trans lf - } - proc readit {s} { - global done - gets $s - close $s - set done 1 - } - set cs [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey [info hostname] 2830] - close $cs - - vwait done - after cancel $timer - set done -} 1 - -test tlsIo-2.11 {detecting new data} {socket knownBug} { - 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]" - close $s - } - - set s [tls::socket -require 0 -request 0 -server accept -certfile $serverCert -cafile $caCert \ - -keyfile $serverKey 2400] - set sock "" - set s2 [tls::socket -certfile $clientCert -cafile $caCert \ - -keyfile $clientKey 127.0.0.1 2400] - vwait sock - puts $s2 one - flush $s2 - after 500 - fconfigure $sock -blocking 0 - set result [gets $sock] - lappend result [gets $sock] - fconfigure $sock -blocking 1 - puts $s2 two - flush $s2 - fconfigure $sock -blocking 0 - lappend result [gets $sock] - fconfigure $sock -blocking 1 - close $s2 - close $s - close $sock - set result -} {one {} 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 2828] - proc accept {file addr port} { - global x - set x done - close $file - } - puts ready - vwait x - after cancel $timer - close $f - puts $x - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f x - if {[catch {tls::socket 127.0.0.1 2828} msg]} { - set x $msg - } else { - lappend x [gets $f] - close $msg - } - lappend x [gets $f] - close $f - set x -} {ready done {}} - - - - -################################# -if {[string match sock* $commandSocket] == 1} { - puts $commandSocket exit - flush $commandSocket -} -catch {close $commandSocket} -catch {close $remoteProcChan} -::tcltest::cleanupTests -flush stdout -return -################################# -test tlsIo-3.1 {socket conflict} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - package require tls - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2828 \]" - puts $f { - puts ready - gets stdin - close $f - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r+] - gets $f - set x [list [catch {tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -server accept 2828} msg] \ - $msg] - puts $f bye - close $f - set x -} {1 {couldn't open socket: address already in use}} - -test tlsIo-3.2 {server with several clients} {socket stdio} { - removeFile script - set f [open script w] - puts $f { - package require tls - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set counter 0 - } - puts $f "set s \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2828 \]" - puts $f { - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } - proc echo {s} { - global x - set l [gets $s] - if {[eof $s]} { - close $s - set x done - } else { - puts $s $l - } - } - puts ready - vwait x - after cancel $t1 - vwait x - after cancel $t2 - vwait x - after cancel $t3 - close $s - puts $x - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r+] - set x [gets $f] - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2828] - fconfigure $s1 -buffering line - set s2 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2828] - fconfigure $s2 -buffering line - set s3 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2828] - fconfigure $s3 -buffering line - for {set i 0} {$i < 100} {incr i} { - puts $s1 hello,s1 - gets $s1 - puts $s2 hello,s2 - gets $s2 - puts $s3 hello,s3 - gets $s3 - } - close $s1 - close $s2 - 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 2828 \]" - puts $f { - fconfigure $s -buffering line - for {set i 0} {$i < 100} {incr i} { - puts $s hello - gets $s - } - close $s - puts bye - gets stdin - } - close $f - set p1 [open "|[list $::tcltest::tcltest script]" r+] - fconfigure $p1 -buffering line - set p2 [open "|[list $::tcltest::tcltest script]" r+] - fconfigure $p2 -buffering line - set p3 [open "|[list $::tcltest::tcltest script]" r+] - fconfigure $p3 -buffering line - proc accept {s a p} { - fconfigure $s -buffering line - fileevent $s readable [list echo $s] - } - proc echo {s} { - global x - set l [gets $s] - if {[eof $s]} { - close $s - set x done - } else { - puts $s $l - } - } - set t1 [after 30000 "set x timed_out"] - set t2 [after 31000 "set x timed_out"] - set t3 [after 32000 "set x timed_out"] - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2828] - puts $p1 open - puts $p2 open - puts $p3 open - vwait x - vwait x - vwait x - after cancel $t1 - after cancel $t2 - after cancel $t3 - close $s - set l "" - lappend l [list p1 [gets $p1] $x] - lappend l [list p2 [gets $p2] $x] - lappend l [list p3 [gets $p3] $x] - puts $p1 bye - puts $p2 bye - puts $p3 bye - close $p1 - close $p2 - close $p3 - set l -} {{p1 bye done} {p2 bye done} {p3 bye done}} - -test tlsIo-4.2 {byte order problems, socket numbers, htons} {socket} { - set x ok - if {[catch {tls::socket -server dodo 0x3000} msg]} { - set x $msg - } else { - close $msg - } - set x -} ok - -test tlsIo-5.1 {byte order problems, socket numbers, htons} \ - {socket unixOnly notRoot} { - set x {couldn't open socket: not owner} - if {![catch {tls::socket -server dodo 0x1} 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-5.2 {byte order problems, socket numbers, htons} {socket} { - set x {couldn't open socket: port number too high} - if {![catch {tls::socket -server dodo 0x10000} msg]} { - set x {port resolution problem, should be disallowed} - close $msg - } - set x -} {couldn't open socket: port number too high} -test tlsIo-5.3 {byte order problems, socket numbers, htons} \ - {socket unixOnly notRoot} { - set x {couldn't open socket: not owner} - 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 pcCrash} { - removeFile script - set f [open script w] - puts $f { - package require tls - gets stdin - tls::socket 127.0.0.1 2848 - } - 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 2848] - 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 "tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2820" - puts $f { - proc accept args { - global x - set x done - } - puts ready - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2820] - set p [fconfigure $s -peername] - close $s - close $f - set l "" - lappend l [string compare [lindex $p 0] 127.0.0.1] - lappend l [string compare [lindex $p 2] 2820] - 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 2821" - puts $f { - proc accept args { - global x - set x done - } - puts ready - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - } - close $f - set f [open "|[list $::tcltest::tcltest script]" r] - gets $f - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2821] - set p [fconfigure $s -sockname] - close $s - close $f - set l "" - lappend l [llength $p] - lappend l [lindex $p 0] - lappend l [string equal [lindex $p 2] 2821] -} {3 127.0.0.1 0} - -test tlsIo-7.3 {testing socket specific options} {socket} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2822] - set l [fconfigure $s] - close $s - update - llength $l -} 12 - -test tlsIo-7.4 {testing socket specific options} {socket} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2823] - proc accept {s a p} { - global x - set x [fconfigure $s -sockname] - close $s - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 2823] - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - close $s1 - set l "" - lappend l [lindex $x 2] [llength $x] -} {2823 3} - -test tlsIo-7.5 {testing socket specific options} {socket unixOrPc} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2829] - proc accept {s a p} { - global x - set x [fconfigure $s -sockname] - close $s - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2829] - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - close $s1 - set l "" - lappend l [lindex $x 0] [lindex $x 2] [llength $x] -} {127.0.0.1 2829 3} - -test tlsIo-8.1 {testing -async flag on sockets} {empty socket} { - # 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, - # 102066-04, 102070-01, 102105-01, 102153-03, 102216-01, 102232-01, - # 101878-03, 101879-01, 101880-03, 101933-01, 101950-01, 102030-01, - # 102057-08, 102140-01, 101920-02, 101921-09, 101922-07, 101923-03 - # - # If after installing these patches you are still experiencing a - # problem, please email jyl@eng.sun.com. We have not observed this - # failure on Solaris 2.5, so another option (instead of installing - # these patches) is to upgrade to Solaris 2.5. - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2830] - proc accept {s a p} { - global x - puts $s bye - close $s - set x done - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -async [info hostname] 2830] - vwait x - set z [gets $s1] - close $s - close $s1 - set z -} bye - -test tlsIo-9.1 {testing spurious events} {empty socket} { - # locks up - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - proc accept {s a p} { - fconfigure $s -buffering none -blocking off - fileevent $s readable [list readlittle $s] - } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2831] - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 2831] - puts -nonewline $c 01234567890123456789012345678901234567890123456789 - close $c - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - close $s - list $spurious $len -} {0 50} - -test tlsIo-9.2 {testing async write, fileevents, flush on close} {socket} { - 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 \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2832] - proc accept {s a p} { - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ - -buffering line - fileevent $s readable "readable $s" - } - proc readable {s} { - set l [gets $s] - fileevent $s readable {} - after 1000 respond $s - } - proc respond {s} { - global firstblock - puts -nonewline $s $firstblock - after 1000 writedata $s - } - proc writedata {s} { - global secondblock - puts -nonewline $s $secondblock - close $s - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 2832] - fconfigure $s -blocking 0 -trans lf -buffering line - set count 0 - puts $s hello - proc readit {s} { - global count done - set l [read $s] - incr count [string length $l] - if {[eof $s]} { - close $s - set done 1 - } - } - fileevent $s readable "readit $s" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - close $l - set count -} 65566 - -test tlsIo-9.3 {testing EOF stickyness} {empty socket} { - # hangs - proc count_to_eof {s} { - global count done timer - set l [gets $s] - if {[eof $s]} { - incr count - if {$count > 9} { - close $s - set done true - set count {eof is sticky} - after cancel $timer - } - } - } - proc timerproc {} { - global done count c - set done true - set count {timer went off, eof is not sticky} - close $c - } - set count 0 - set done false - proc write_then_close {s} { - puts $s bye - close $s - } - proc accept {s a p} { - fconfigure $s -buffering line -translation lf - fileevent $s writable "write_then_close $s" - } - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2833] - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - [info hostname] 2833] - fconfigure $c -blocking off -buffering line -translation lf - fileevent $c readable "count_to_eof $c" - set timer [after 1000 timerproc] - vwait done - close $s - set count -} {eof is sticky} - -removeFile script - -test tlsIo-10.1 {testing socket accept callback error handling} {socket} { - set goterror 0 - proc bgerror args {global goterror; set goterror 1} - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2898] - proc accept {s a p} {close $s; error} - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2898] - vwait goterror - close $s - close $c - set goterror -} 1 - -test tlsIo-11.1 {tcp connection} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - set socket9_1_test_server [tls::socket -server accept \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - 2834] - proc accept {s a p} { - puts $s done - tls::handshake $s - close $s - } - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2834] - set r [gets $s] - close $s - sendCommand {close $socket9_1_test_server} - set r -} done - -test tlsIo-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - if {[info exists port]} { - incr port - } else { - set port [expr 2048 + [pid]%1024] - } - sendCommand { - set socket9_2_test_server [tls::socket -server accept \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - 2835] - proc accept {s a p} { - tls::handshake $s - puts $s $p - close $s - } - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - -myport $port $remoteServerIP 2835] - set r [gets $s] - close $s - sendCommand {close $socket9_2_test_server} - if {$r == $port} { - set result ok - } else { - set result broken - } - set result -} ok -test tlsIo-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { - set status ok - if {![catch {set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIp 2836]}]} { - if {![catch {gets $s}]} { - set status broken - } - close $s - } - set status -} ok - -test tlsIo-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - global serverCert - global caCert - global serverKey - set socket10_6_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - -server accept 2836] - proc accept {s a p} { - tls::handshake $s - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - close $s - } else { - puts $s $l - } - } - } - set f [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fconfigure $f -translation crlf -buffering line - puts $f hello - set r [gets $f] - close $f - sendCommand {close $socket10_6_test_server} - set r -} hello - -test tlsIo-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - set socket10_7_test_server [tls::socket -server accept \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - 2836] - proc accept {s a p} { - tls::handshake $s - fileevent $s readable [list echo $s] - fconfigure $s -buffering line -translation crlf - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - close $s - } else { - puts $s $l - } - } - } - set f [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fconfigure $f -translation crlf -buffering line - for {set cnt 0} {$cnt < 50} {incr cnt} { - puts $f "hello, $cnt" - if {[string compare [gets $f] "hello, $cnt"] != 0} { - break - } - } - close $f - sendCommand {close $socket10_7_test_server} - set cnt -} 50 - -# Macintosh sockets can have more than one server per port -if {$tcl_platform(platform) == "macintosh"} { - set conflictResult {0 2836} -} else { - set conflictResult {1 {couldn't open socket: address already in use}} -} - -test tlsIo-11.6 {socket conflict} {socket doTestsWithRemoteServer} { - set s1 [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2836] - if {[catch {set s2 [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2836]} msg]} { - set result [list 1 $msg] - } else { - set result [list 0 [lindex [fconfigure $s2 -sockname] 2]] - close $s2 - } - close $s1 - set result -} $conflictResult - -test tlsIo-11.7 {server with several clients} {socket doTestsWithRemoteServer} { - sendCommand { - set socket10_9_test_server [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server accept 2836] - proc accept {s a p} { - # handshake locks up the three synchronous clients - # tls::handshake $s - fconfigure $s -buffering line - fileevent $s readable [list echo $s] - } - proc echo {s} { - set l [gets $s] - if {[eof $s]} { - close $s - } else { - puts $s $l - } - } - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fconfigure $s1 -buffering line - set s2 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fconfigure $s2 -buffering line - set s3 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fconfigure $s3 -buffering line - for {set i 0} {$i < 100} {incr i} { - puts $s1 hello,s1 - gets $s1 - puts $s2 hello,s2 - gets $s2 - puts $s3 hello,s3 - gets $s3 - } - close $s1 - close $s2 - close $s3 - sendCommand {close $socket10_9_test_server} - set i -} 100 - -test tlsIo-11.8 {client with several servers} {empty socket doTestsWithRemoteServer} { - # this one seems to hang -- awb 6/2/2000 - sendCommand { - set s1 [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server "accept 4003" 4003] - set s2 [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server "accept 4004" 4004] - set s3 [tls::socket \ - -certfile [file join [pwd] certs server.pem] \ - -cafile [file join [pwd] certs caFile.pem] \ - -keyfile [file join [pwd] certs skey.pem] \ - -server "accept 4005" 4005] - proc accept {mp s a p} { - tls::handshake $s - puts $s $mp - close $s - } - } - set s1 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 4003] - set s2 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 4004] - set s3 [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 4005] - set l "" - lappend l [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \ - [gets $s3] [gets $s3] [eof $s3] - close $s1 - close $s2 - close $s3 - sendCommand { - close $s1 - close $s2 - close $s3 - } - set l -} {4003 {} 1 4004 {} 1 4005 {} 1} - -test tlsIo-11.9 {accept callback error} {socket doTestsWithRemoteServer} { - set s [tls::socket \ - -certfile $serverCert -cafile $caCert -keyfile $serverKey \ - -server accept 2836] - proc accept {s a p} {expr 10 / 0} - proc bgerror args { - global x - set x $args - } - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - if {[catch {sendCommand { - set peername [fconfigure $callerSocket -peername] - set s [tls::socket \ - -certfile $clientCert \ - -cafile $caCert \ - -keyfile $clientKey \ - [lindex $peername 0] 2836] - close $s - }} msg]} { - close $s - error $msg - } - set timer [after 10000 "set x timed_out"] - vwait x - after cancel $timer - close $s - rename bgerror {} - set x -} {{divide by zero}} - -test tlsIo-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - set socket10_12_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - -server accept 2836] - proc accept {s a p} {close $s} - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - set p [fconfigure $s -peername] - set n [fconfigure $s -sockname] - set l "" - lappend l [lindex $p 2] [llength $p] [llength $p] - close $s - sendCommand {close $socket10_12_test_server} - set l -} {2836 3 3} - -test tlsIo-11.11 {testing spurious events} {empty socket doTestsWithRemoteServer} { - # hangs - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - set socket10_13_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - -server accept 2836] - proc accept {s a p} { - tls::handshake $s - fconfigure $s -translation "auto lf" - after 100 writesome $s - } - proc writesome {s} { - for {set i 0} {$i < 100} {incr i} { - puts $s "line $i from remote server" - } - close $s - } - } - set len 0 - set spurious 0 - set done 0 - proc readlittle {s} { - global spurious done len - set l [read $s 1] - if {[string length $l] == 0} { - if {![eof $s]} { - incr spurious - } else { - close $s - set done 1 - } - } else { - incr len [string length $l] - } - } - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fileevent $c readable "readlittle $c" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - sendCommand {close $socket10_13_test_server} - list $spurious $len -} {0 2690} - -test tlsIo-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} { - set counter 0 - set done 0 - proc count_up {s} { - global counter done after_id - set l [gets $s] - if {[eof $s]} { - incr counter - if {$counter > 9} { - set done {EOF is sticky} - after cancel $after_id - close $s - } - } - } - proc timed_out {} { - global c done - set done {timed_out, EOF is not sticky} - close $c - } - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - set socket10_14_test_server [tls::socket \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - -server accept 2836] - proc accept {s a p} { - tls::handshake $s - after 100 close $s - } - } - set c [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2836] - fileevent $c readable "count_up $c" - set after_id [after 1000 timed_out] - vwait done - sendCommand {close $socket10_14_test_server} - set done -} {EOF is sticky} - -test tlsIo-11.13 {testing async write, async flush, async close} \ - {socket doTestsWithRemoteServer} { - proc readit {s} { - global count done - set l [read $s] - incr count [string length $l] - if {[eof $s]} { - close $s - set done 1 - } - } - sendCommand "set caCert $caCert" - sendCommand "set serverCert $serverCert" - sendCommand "set clientCert $clientCert" - sendCommand "set serverKey $serverKey" - sendCommand "set clientKey $clientKey" - sendCommand { - 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 \ - -certfile $serverCert \ - -cafile $caCert \ - -keyfile $serverKey \ - -server accept 2845] - proc accept {s a p} { - tls::handshake $s - fconfigure $s -blocking 0 -translation lf -buffersize 16384 \ - -buffering line - fileevent $s readable "readable $s" - } - proc readable {s} { - set l [gets $s] - fileevent $s readable {} - after 1000 respond $s - } - proc respond {s} { - global firstblock - puts -nonewline $s $firstblock - after 1000 writedata $s - } - proc writedata {s} { - global secondblock - puts -nonewline $s $secondblock - close $s - } - } - set s [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - $remoteServerIP 2845] - fconfigure $s -blocking 0 -trans lf -buffering line - set count 0 - puts $s hello - fileevent $s readable "readit $s" - set timer [after 10000 "set done timed_out"] - vwait done - after cancel $timer - sendCommand {close $l} - set count -} 65566 - -test tlsIo-12.1 {testing inheritance of server sockets} \ - {socket doTestsWithRemoteServer} { - removeFile script1 - removeFile script2 - - # Script1 is just a 10 second delay. If the server socket - # is inherited, it will be held open for 10 seconds - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - # Script2 creates the server socket, launches script1, - # waits a second, and exits. The server socket will now - # be closed unless script1 inherited it. - - set f [open script2 w] - # puts $f [list set tcltest $::tcltest::tcltest] - puts $f [list set tclsh [info nameofexecutable]] - puts $f { - package require tcltest - package require tls - } - puts $f "set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2828 \]" - puts $f { - proc accept { file addr port } { - close $file - } - # exec $::tcltest::tcltest script1 & - exec $tclsh script1 & - close $f - after 1000 exit - vwait forever - } - close $f - - # Launch script2 and wait 5 seconds - - # exec $::tcltest::tcltest script2 & - exec [info nameofexecutable] 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 \ - -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 - removeFile script2 - set x -} {server socket was not inherited} - -test tlsIo-12.2 {testing inheritance of client sockets} \ - {socket doTestsWithRemoteServer} { - removeFile script1 - removeFile script2 - - # Script1 is just a 10 second delay. If the server socket - # is inherited, it will be held open for 10 seconds - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - # Script2 opens the client socket and writes to it. It then - # launches script1 and exits. If the child process inherited the - # client socket, the socket will still be open. - - set f [open script2 w] - puts $f [list set tclsh [info nameofexecutable]] - puts $f { - package require tls - } - puts $f "set f \[tls::socket -certfile $clientCert -cafile $caCert -keyfile $clientKey 127.0.0.1 2829 \]" - puts $f { - exec $tclsh script1 & - puts $f testing - flush $f - after 1000 exit - vwait forever - } - close $f - - # Create the server socket - - 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 - return - } - proc getdata { file } { - - # Read handler on the accepted socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x {client socket was inherited} - } else { - set x {client socket was not inherited} - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } - return - } - - # If the socket doesn't hit end-of-file in 5 seconds, the - # script1 process must have inherited the client. - - set failed 0 - after 5000 [list set failed 1] - - # Launch the script2 process - - exec [info nameofexecutable] script2 & - - vwait x - if {!$failed} { - vwait failed - } - removeFile script1 - removeFile script2 - set x -} {client socket was not inherited} - -test tlsIo-12.3 {testing inheritance of accepted sockets} \ - {empty socket doTestsWithRemoteServer} { - # hangs on Linux - removeFile script1 - removeFile script2 - - set f [open script1 w] - puts $f { - after 10000 exit - vwait forever - } - close $f - - set f [open script2 w] - puts $f [list set tclsh [info nameofexecutable]] - puts $f { - package require tls - } - puts $f "catch {set f \[tls::socket -server accept -certfile $serverCert -cafile $caCert -keyfile $serverKey 2930 \]}" - puts $f { - proc accept { file host port } { - global tclsh - puts $file {test data on socket} - exec $tclsh script1 & - after 1000 exit - } - catch {vwait forever} - } - close $f - - # Launch the script2 process and connect to it. See how long - # the socket stays open - - exec [info nameofexecutable] script2 & - - after 1000 set ok_to_proceed 1 - vwait ok_to_proceed - - set f [tls::socket \ - -certfile $clientCert -cafile $caCert -keyfile $clientKey \ - 127.0.0.1 2930] - fconfigure $f -buffering full -blocking 0 - fileevent $f readable [list getdata $f] - - # If the socket is still open after 5 seconds, the script1 process - # must have inherited the accepted socket. - - set failed 0 - after 5000 set failed 1 - - proc getdata { file } { - - # Read handler on the client socket. - global x - global failed - set status [catch {read $file} data] - if {$status != 0} { - set x {read failed, error was $data} - catch { close $file } - } elseif {[string compare {} $data]} { - } elseif {[fblocked $file]} { - } elseif {[eof $file]} { - if {$failed} { - set x {accepted socket was inherited} - } else { - set x {accepted socket was not inherited} - } - catch { close $file } - } else { - set x {impossible case} - catch { close $file } - } - return - } - - vwait x - - removeFile script1 - removeFile script2 - set x -} {accepted socket was not inherited} - -test tlsIo-13.1 {Testing use of shared socket between two threads} \ - {socket testthread} { - - removeFile script - threadReap - - makeFile { - package require tls - set f [tls::socket -server accept 2828] - proc accept {s a p} { - fileevent $s readable [list echo $s] - fconfigure $s -buffering line - } - proc echo {s} { - global i - set l [gets $s] - if {[eof $s]} { - global x - close $s - set x done - } else { - incr i - puts $s $l - } - } - set i 0 - vwait x - close $f - - # thread cleans itself up. - testthread exit - } script - - # create a thread - set serverthread [testthread create { source script } ] - update - - after 1000 - set s [tls::socket 127.0.0.1 2828] - fconfigure $s -buffering line - - catch { - puts $s "hello" - gets $s result - } - close $s - update - - after 2000 - lappend result [threadReap] - - set result - -} {hello 1} - -# cleanup -if {[string match sock* $commandSocket] == 1} { - puts $commandSocket exit - flush $commandSocket -} -catch {close $commandSocket} -catch {close $remoteProcChan} -::tcltest::cleanupTests -flush stdout -return -