ADDED tests/tlsIo.test Index: tests/tlsIo.test ================================================================== --- /dev/null +++ tests/tlsIo.test @@ -0,0 +1,1672 @@ +# 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-1999 by Scriptics Corporation. +# +# 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.1 2000/06/02 18:47:38 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 +# 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 + +# 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 $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 $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 disappaered" + } + 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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-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 socket-1.12 {arg parsing for socket command} {socket} { + list [catch {tls::socket foo badport} msg] $msg +} {1 {expected integer but got "badport"}} + +test socket-2.1 {tcp connection} {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 [info exists port] { + incr port +} else { + set port [expr 2048 + [pid]%1024] +} +test socket-2.2 {tcp connection with client port specified} {socket stdio pcCrash} { + removeFile script + set f [open script w] + puts $f { + package require tls + set timer [after 2000 "set x done"] + set f [tls::socket -server accept 2829] + 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 127.0.0.1 2829} sock]} { + set x $sock + close [tls::socket 127.0.0.1 2829] + puts stderr $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} [list ready "hello $port"] +test socket-2.3 {tcp connection with client interface specified} {socket stdio pcCrash} { + removeFile script + set f [open script w] + puts $f { + package require tls + set timer [after 2000 "set x done"] + set f [tls::socket -server accept 2830] + 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 127.0.0.1 2830} sock]} { + set x $sock + } else { + puts $sock hello + flush $sock + lappend x [gets $f] + close $sock + } + close $f + set x +} {ready {hello 127.0.0.1}} +test socket-2.4 {tcp connection with server interface specified} {socket stdio pcCrash} { + removeFile script + set f [open script w] + puts $f { + package require tls + set timer [after 2000 "set x done"] + set f [tls::socket -server accept -myaddr [info hostname] 2831] + 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 [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 socket-2.5 {tcp connection with redundant server port} {socket stdio pcCrash} { + removeFile script + set f [open script w] + puts $f { + package require tls + set timer [after 2000 "set x done"] + set f [tls::socket -server accept 2832] + 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 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 socket-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 socket-2.7 {echo server, one line} {socket stdio pcCrash} { + removeFile script + set f [open script w] + puts $f { + package require tls + set timer [after 2000 "set x done"] + set f [tls::socket -server accept 2834] + 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 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 socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { + makeFile { + set f [tls::socket -server accept 2835] + 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" + } script + set f [open "|[list $::tcltest::tcltest script]" r] + gets $f + set s [tls::socket 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 socket-2.9 {socket conflict} {socket stdio} { + set s [tls::socket -server accept 2828] + removeFile script + set f [open script w] + puts -nonewline $f {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 accept 2828" + (file "script" line 1)}} + +test socket-2.10 {close on accept, accepted socket lives} {socket pcCrash} { + set done 0 + set timer [after 20000 "set done timed_out"] + set ss [tls::socket -server accept 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 [info hostname] 2830] + puts $cs hello + close $cs + vwait done + after cancel $timer + set done +} 1 +test socket-2.11 {detecting new data} {socket pcCrash} { + proc accept {s a p} { + global sock + set sock $s + } + + set s [tls::socket -server accept 2400] + set sock "" + set s2 [tls::socket 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 socket-3.1 {socket conflict} {socket stdio} { + removeFile script + set f [open script w] + puts $f { + set f [tls::socket -server accept 2828] + puts ready + gets stdin + close $f + } + close $f + set f [open "|[list $::tcltest::tcltest script]" r+] + gets $f + set x [list [catch {tls::socket -server accept 2828} msg] \ + $msg] + puts $f bye + close $f + set x +} {1 {couldn't open socket: address already in use}} + +test socket-3.2 {server with several clients} {socket stdio pcCrash} { + removeFile script + set f [open script w] + puts $f { + 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 + set s [tls::socket -server accept 2828] + 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 127.0.0.1 2828] + fconfigure $s1 -buffering line + set s2 [tls::socket 127.0.0.1 2828] + fconfigure $s2 -buffering line + set s3 [tls::socket 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 socket-4.1 {server with several clients} {socket stdio} { + removeFile script + set f [open script w] + puts $f { + gets stdin + set s [socket 127.0.0.1 2828] + 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 -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 socket-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 socket-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 socket-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 socket-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 socket-6.1 {accept callback error} {socket stdio} { + removeFile script + set f [open script w] + puts $f { + 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 socket-7.1 {testing socket specific options} {socket stdio} { + removeFile script + set f [open script w] + puts $f { + tls::socket -server accept 2820 + 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 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 socket-7.2 {testing socket specific options} {socket stdio} { + removeFile script + set f [open script w] + puts $f { + tls::socket -server accept 2821 + 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 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 [expr [lindex $p 2] == 2821] +} {3 127.0.0.1 0} +test socket-7.3 {testing socket specific options} {socket} { + set s [tls::socket -server accept 2822] + set l [fconfigure $s] + close $s + update + llength $l +} 12 +test socket-7.4 {testing socket specific options} {socket pcCrash} { + set s [tls::socket -server accept 2823] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [tls::socket [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 socket-7.5 {testing socket specific options} {socket unixOrPc pcCrash} { + set s [tls::socket -server accept 2829] + proc accept {s a p} { + global x + set x [fconfigure $s -sockname] + close $s + } + set s1 [tls::socket 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 socket-8.1 {testing -async flag on sockets} {socket pcCrash} { + # 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 -server accept 2830] + proc accept {s a p} { + global x + puts $s bye + close $s + set x done + } + set s1 [tls::socket -async [info hostname] 2830] + vwait x + set z [gets $s1] + close $s + close $s1 + set z +} bye + +test socket-9.1 {testing spurious events} {socket pcCrash} { + 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 -server accept 2831] + set c [tls::socket [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 socket-9.2 {testing async write, fileevents, flush on close} {socket pcCrash} { + 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 -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 [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 socket-9.3 {testing EOF stickyness} {socket pcCrash} { + 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 -server accept 2833] + set c [tls::socket [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 socket-10.1 {testing socket accept callback error handling} {socket pcCrash} { + set goterror 0 + proc bgerror args {global goterror; set goterror 1} + set s [tls::socket -server accept 2898] + proc accept {s a p} {close $s; error} + set c [tls::socket 127.0.0.1 2898] + vwait goterror + close $s + close $c + set goterror +} 1 + +test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} { + sendCommand { + set socket9_1_test_server [tls::socket -server accept 2834] + proc accept {s a p} { + puts $s done + close $s + } + } + set s [tls::socket $remoteServerIP 2834] + set r [gets $s] + close $s + sendCommand {close $socket9_1_test_server} + set r +} done +test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { + if {[info exists port]} { + incr port + } else { + set port [expr 2048 + [pid]%1024] + } + sendCommand { + set socket9_2_test_server [tls::socket -server accept 2835] + proc accept {s a p} { + puts $s $p + close $s + } + } + set s [tls::socket -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 socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { + set status ok + if {![catch {set s [tls::socket $remoteServerIp 2836]}]} { + if {![catch {gets $s}]} { + set status broken + } + close $s + } + set status +} ok +test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { + sendCommand { + set socket10_6_test_server [tls::socket -server accept 2836] + proc accept {s a p} { + 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 $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 socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { + sendCommand { + set socket10_7_test_server [tls::socket -server accept 2836] + proc accept {s a p} { + 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 $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 socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} { + set s1 [tls::socket -server accept 2836] + if {[catch {set s2 [tls::socket -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 socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} { + sendCommand { + set socket10_9_test_server [tls::socket -server accept 2836] + proc accept {s a p} { + 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 $remoteServerIP 2836] + fconfigure $s1 -buffering line + set s2 [tls::socket $remoteServerIP 2836] + fconfigure $s2 -buffering line + set s3 [tls::socket $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 socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} { + sendCommand { + set s1 [tls::socket -server "accept 4003" 4003] + set s2 [tls::socket -server "accept 4004" 4004] + set s3 [tls::socket -server "accept 4005" 4005] + proc accept {mp s a p} { + puts $s $mp + close $s + } + } + set s1 [tls::socket $remoteServerIP 4003] + set s2 [tls::socket $remoteServerIP 4004] + set s3 [tls::socket $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 socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} { + set s [tls::socket -server accept 2836] + proc accept {s a p} {expr 10 / 0} + proc bgerror args { + global x + set x $args + } + if {[catch {sendCommand { + set peername [fconfigure $callerSocket -peername] + set s [tls::socket [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 socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { + sendCommand { + set socket10_12_test_server [tls::socket -server accept 2836] + proc accept {s a p} {close $s} + } + set s [tls::socket $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 socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { + sendCommand { + set socket10_13_test_server [tls::socket -server accept 2836] + proc accept {s a p} { + 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 $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 socket-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 socket10_14_test_server [tls::socket -server accept 2836] + proc accept {s a p} { + after 100 close $s + } + } + set c [tls::socket $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 socket-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 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 -server accept 2845] + 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 $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 socket-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 { + package require tcltest + set f [tls::socket -server accept 2828] + proc accept { file addr port } { + close $file + } + exec $::tcltest::tcltest script1 & + close $f + after 1000 exit + vwait forever + } + close $f + + # Launch script2 and wait 5 seconds + + 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]} { + 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 socket-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 tcltest $::tcltest::tcltest] + puts $f { + set f [tls::socket 127.0.0.1 2829] + 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] + 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 $::tcltest::tcltest script2 & + + vwait x + if {!$failed} { + vwait failed + } + removeFile script1 + removeFile script2 + set x +} {client socket was not inherited} +test socket-12.3 {testing inheritance of accepted sockets} \ + {socket doTestsWithRemoteServer} { + 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 tcltest $::tcltest::tcltest] + puts $f { + set server [tls::socket -server accept 2930] + proc accept { file host port } { + global tcltest + puts $file {test data on socket} + exec $::tcltest::tcltest script1 & + after 1000 exit + } + vwait forever + } + close $f + + # Launch the script2 process and connect to it. See how long + # the socket stays open + + exec $::tcltest::tcltest script2 & + + after 1000 set ok_to_proceed 1 + vwait ok_to_proceed + + set f [tls::socket 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 socket-13.1 {Testing use of shared socket between two threads} \ + {socket testthread} { + + removeFile script + threadReap + + makeFile { + 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 + + + + + + + + + + +