diff options
author | stanton <stanton@noemail.net> | 1999-04-16 00:46:29 (GMT) |
---|---|---|
committer | stanton <stanton@noemail.net> | 1999-04-16 00:46:29 (GMT) |
commit | 98569293dc21e22480004e4e3f2ce85ec0bfd80f (patch) | |
tree | ce9959f2747257d98d52ec8d18bf3b0de99b9535 /tests/socket.test | |
parent | 6a4a1d8213f4de5bce0eaafa8f4d86117022bf1a (diff) | |
download | tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.zip tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.tar.gz tcl-98569293dc21e22480004e4e3f2ce85ec0bfd80f.tar.bz2 |
merged tcl 8.1 branch back into the main trunk
FossilOrigin-Name: f3b32fb71c9011ac220779bd9dbe5617c9dc87d9
Diffstat (limited to 'tests/socket.test')
-rw-r--r-- | tests/socket.test | 338 |
1 files changed, 207 insertions, 131 deletions
diff --git a/tests/socket.test b/tests/socket.test index 5ff563a..249dc5e 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -5,10 +5,13 @@ # 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: socket.test,v 1.7 1999/04/16 00:47:34 stanton Exp $ + # Running socket tests with a remote server: # ------------------------------------------ # @@ -58,15 +61,16 @@ # 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. -# -# RCS: @(#) $Id: socket.test,v 1.6 1998/12/04 01:01:55 stanton Exp $ - -if {[string compare test [info procs test]] == 1} then {source defs} -if {$testConfig(socket) == 0} { - return +if {[lsearch [namespace children] ::tcltest] == -1} { + source [file join [pwd] [file dirname [info script]] defs.tcl] } +# Some tests require the testthread command + +set ::tcltest::testConfig(testthread) \ + [expr {[info commands testthread] != {}}] + # # If remoteServerIP or remoteServerPort are not set, check in the # environment variables for externally set values. @@ -93,7 +97,7 @@ if {![info exists remoteServerPort]} { set doTestsWithRemoteServer 1 if {![info exists remoteServerIP] && ($tcl_platform(platform) != "macintosh")} { - set remoteServerIP localhost + set remoteServerIP 127.0.0.1 } if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} { set remoteServerPort 2048 @@ -115,13 +119,11 @@ if {$doTestsWithRemoteServer} { if {[info commands exec] == ""} { set noRemoteTestReason "can't exec" set doTestsWithRemoteServer 0 - } elseif {$testConfig(win32s)} { - set noRemoteTestReason "\ncan't run multiple instances of tcltest under win32s." - set doTestsWithRemoteServer 0 } else { - set remoteServerIP localhost + set remoteServerIP 127.0.0.1 + set remoteFile [file join [pwd] remote.tcl] if {[catch {set remoteProcChan \ - [open "|[list $tcltest remote.tcl \ + [open "|[list $tcltest $remoteFile \ -serverIsSilent \ -port $remoteServerPort \ -address $remoteServerIP]" \ @@ -145,10 +147,12 @@ if {$doTestsWithRemoteServer} { } } +# Some tests are run only if we are doing testing against a remote server. +set ::tcltest::testConfig(doTestsWithRemoteServer) $doTestsWithRemoteServer if {$doTestsWithRemoteServer == 0} { - puts "Skipping tests with remote server. See tests/socket.test for" - puts "information on how to run remote server." - if {[info exists VERBOSE] && ($VERBOSE != 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" } } @@ -192,54 +196,54 @@ if {$doTestsWithRemoteServer == 1} { } } -test socket-1.1 {arg parsing for socket command} { +test socket-1.1 {arg parsing for socket command} {socket} { list [catch {socket -server} msg] $msg } {1 {no argument given for -server option}} -test socket-1.2 {arg parsing for socket command} { +test socket-1.2 {arg parsing for socket command} {socket} { list [catch {socket -server foo} msg] $msg } {1 {wrong # args: should be either: socket ?-myaddr addr? ?-myport myport? ?-async? host port socket -server command ?-myaddr addr? port}} -test socket-1.3 {arg parsing for socket command} { +test socket-1.3 {arg parsing for socket command} {socket} { list [catch {socket -myaddr} msg] $msg } {1 {no argument given for -myaddr option}} -test socket-1.4 {arg parsing for socket command} { +test socket-1.4 {arg parsing for socket command} {socket} { list [catch {socket -myaddr 127.0.0.1} msg] $msg } {1 {wrong # args: should be either: socket ?-myaddr addr? ?-myport myport? ?-async? host port socket -server command ?-myaddr addr? port}} -test socket-1.5 {arg parsing for socket command} { +test socket-1.5 {arg parsing for socket command} {socket} { list [catch {socket -myport} msg] $msg } {1 {no argument given for -myport option}} -test socket-1.6 {arg parsing for socket command} { +test socket-1.6 {arg parsing for socket command} {socket} { list [catch {socket -myport xxxx} msg] $msg } {1 {expected integer but got "xxxx"}} -test socket-1.7 {arg parsing for socket command} { +test socket-1.7 {arg parsing for socket command} {socket} { list [catch {socket -myport 2522} msg] $msg } {1 {wrong # args: should be either: socket ?-myaddr addr? ?-myport myport? ?-async? host port socket -server command ?-myaddr addr? port}} -test socket-1.8 {arg parsing for socket command} { +test socket-1.8 {arg parsing for socket command} {socket} { list [catch {socket -froboz} msg] $msg -} {1 {bad option "-froboz", must be -async, -myaddr, -myport, or -server}} -test socket-1.9 {arg parsing for socket command} { +} {1 {bad option "-froboz": must be -async, -myaddr, -myport, or -server}} +test socket-1.9 {arg parsing for socket command} {socket} { list [catch {socket -server foo -myport 2521 3333} msg] $msg } {1 {Option -myport is not valid for servers}} -test socket-1.10 {arg parsing for socket command} { +test socket-1.10 {arg parsing for socket command} {socket} { list [catch {socket host 2528 -junk} msg] $msg } {1 {wrong # args: should be either: socket ?-myaddr addr? ?-myport myport? ?-async? host port socket -server command ?-myaddr addr? port}} -test socket-1.11 {arg parsing for socket command} { +test socket-1.11 {arg parsing for socket command} {socket} { list [catch {socket -server callback 2520 --} msg] $msg } {1 {wrong # args: should be either: socket ?-myaddr addr? ?-myport myport? ?-async? host port socket -server command ?-myaddr addr? port}} -test socket-1.12 {arg parsing for socket command} { +test socket-1.12 {arg parsing for socket command} {socket} { list [catch {socket foo badport} msg] $msg } {1 {expected integer but got "badport"}} -test socket-2.1 {tcp connection} {stdio} { +test socket-2.1 {tcp connection} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -259,7 +263,7 @@ test socket-2.1 {tcp connection} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket localhost 2828} msg]} { + if {[catch {socket 127.0.0.1 2828} msg]} { set x $msg } else { lappend x [gets $f] @@ -275,12 +279,12 @@ if [info exists port] { } else { set port [expr 2048 + [pid]%1024] } -test socket-2.2 {tcp connection with client port specified} {stdio} { +test socket-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2829] proc accept {file addr port} { global x puts "[gets $file] $port" @@ -296,9 +300,9 @@ test socket-2.2 {tcp connection with client port specified} {stdio} { set f [open "|[list $tcltest script]" r] gets $f x global port - if {[catch {socket -myport $port localhost 2828} sock]} { + if {[catch {socket -myport $port 127.0.0.1 2829} sock]} { set x $sock - close [socket localhost 2828] + close [socket 127.0.0.1 2829] puts stderr $sock } else { puts $sock hello @@ -309,12 +313,12 @@ test socket-2.2 {tcp connection with client port specified} {stdio} { close $f set x } [list ready "hello $port"] -test socket-2.3 {tcp connection with client interface specified} {stdio} { +test socket-2.3 {tcp connection with client interface specified} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2830] proc accept {file addr port} { global x puts "[gets $file] $addr" @@ -329,7 +333,7 @@ test socket-2.3 {tcp connection with client interface specified} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket -myaddr localhost localhost 2828} sock]} { + if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} { set x $sock } else { puts $sock hello @@ -340,12 +344,12 @@ test socket-2.3 {tcp connection with client interface specified} {stdio} { close $f set x } {ready {hello 127.0.0.1}} -test socket-2.4 {tcp connection with server interface specified} {stdio} { +test socket-2.4 {tcp connection with server interface specified} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept -myaddr [info hostname] 2828] + set f [socket -server accept -myaddr [info hostname] 2831] proc accept {file addr port} { global x puts "[gets $file]" @@ -360,7 +364,7 @@ test socket-2.4 {tcp connection with server interface specified} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket [info hostname] 2828} sock]} { + if {[catch {socket [info hostname] 2831} sock]} { set x $sock } else { puts $sock hello @@ -371,12 +375,12 @@ test socket-2.4 {tcp connection with server interface specified} {stdio} { close $f set x } {ready hello} -test socket-2.5 {tcp connection with redundant server port} {stdio} { +test socket-2.5 {tcp connection with redundant server port} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2832] proc accept {file addr port} { global x puts "[gets $file]" @@ -391,7 +395,7 @@ test socket-2.5 {tcp connection with redundant server port} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f x - if {[catch {socket localhost 2828} sock]} { + if {[catch {socket 127.0.0.1 2832} sock]} { set x $sock } else { puts $sock hello @@ -402,9 +406,9 @@ test socket-2.5 {tcp connection with redundant server port} {stdio} { close $f set x } {ready hello} -test socket-2.6 {tcp connection} {} { +test socket-2.6 {tcp connection} {socket} { set status ok - if {![catch {set sock [socket localhost 2828]}]} { + if {![catch {set sock [socket 127.0.0.1 2833]}]} { if {![catch {gets $sock}]} { set status broken } @@ -412,12 +416,12 @@ test socket-2.6 {tcp connection} {} { } set status } ok -test socket-2.7 {echo server, one line} {stdio} { +test socket-2.7 {echo server, one line} {socket stdio} { removeFile script set f [open script w] puts $f { set timer [after 2000 "set x done"] - set f [socket -server accept 2828] + set f [socket -server accept 2834] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -translation lf -buffering line @@ -441,20 +445,19 @@ test socket-2.7 {echo server, one line} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2828] + set s [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} {stdio} { - removeFile script - set f [open script w] - puts $f { - set f [socket -server accept 2828] +test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { + makeFile { + set f [socket -server accept 2835] proc accept {s a p} { fileevent $s readable [list echo $s] fconfigure $s -buffering line @@ -478,26 +481,27 @@ test socket-2.8 {echo server, loop 50 times, single connection} {stdio} { after cancel $timer close $f puts "done $i" - } - close $f + } script set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2828] + set s [socket 127.0.0.1 2835] fconfigure $s -buffering line - for {set x 0} {$x < 50} {incr x} { - puts $s "hello abcdefghijklmnop" - gets $s + catch { + for {set x 0} {$x < 50} {incr x} { + puts $s "hello abcdefghijklmnop" + gets $s + } } close $s - set x [gets $f] + catch {set x [gets $f]} close $f set x } {done 50} -test socket-2.9 {socket conflict} {stdio} { +test socket-2.9 {socket conflict} {socket stdio} { set s [socket -server accept 2828] removeFile script set f [open script w] - puts $f {set f [socket -server accept 2828]} + puts -nonewline $f {socket -server accept 2828} close $f set f [open "|[list $tcltest script]" r] gets $f @@ -509,7 +513,7 @@ test socket-2.9 {socket conflict} {stdio} { while executing "socket -server accept 2828" (file "script" line 1)}} -test socket-2.10 {close on accept, accepted socket lives} { +test socket-2.10 {close on accept, accepted socket lives} {socket} { set done 0 set timer [after 20000 "set done timed_out"] set ss [socket -server accept 2830] @@ -532,7 +536,7 @@ test socket-2.10 {close on accept, accepted socket lives} { after cancel $timer set done } 1 -test socket-2.11 {detecting new data} { +test socket-2.11 {detecting new data} {socket} { proc accept {s a p} { global sock set sock $s @@ -540,7 +544,7 @@ test socket-2.11 {detecting new data} { set s [socket -server accept 2400] set sock "" - set s2 [socket localhost 2400] + set s2 [socket 127.0.0.1 2400] vwait sock puts $s2 one flush $s2 @@ -561,7 +565,7 @@ test socket-2.11 {detecting new data} { } {one {} two} -test socket-3.1 {socket conflict} {stdio} { +test socket-3.1 {socket conflict} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -579,7 +583,7 @@ test socket-3.1 {socket conflict} {stdio} { close $f set x } {1 {couldn't open socket: address already in use}} -test socket-3.2 {server with several clients} {stdio} { +test socket-3.2 {server with several clients} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -615,11 +619,11 @@ test socket-3.2 {server with several clients} {stdio} { close $f set f [open "|[list $tcltest script]" r+] set x [gets $f] - set s1 [socket localhost 2828] + set s1 [socket 127.0.0.1 2828] fconfigure $s1 -buffering line - set s2 [socket localhost 2828] + set s2 [socket 127.0.0.1 2828] fconfigure $s2 -buffering line - set s3 [socket localhost 2828] + set s3 [socket 127.0.0.1 2828] fconfigure $s3 -buffering line for {set i 0} {$i < 100} {incr i} { puts $s1 hello,s1 @@ -637,12 +641,12 @@ test socket-3.2 {server with several clients} {stdio} { set x } {ready done} -test socket-4.1 {server with several clients} {stdio} { +test socket-4.1 {server with several clients} {socket stdio} { removeFile script set f [open script w] puts $f { gets stdin - set s [socket localhost 2828] + set s [socket 127.0.0.1 2828] fconfigure $s -buffering line for {set i 0} {$i < 100} {incr i} { puts $s hello @@ -699,7 +703,7 @@ test socket-4.1 {server with several clients} {stdio} { close $p3 set l } {{p1 bye done} {p2 bye done} {p3 bye done}} -test socket-4.2 {byte order problems, socket numbers, htons} { +test socket-4.2 {byte order problems, socket numbers, htons} {socket} { set x ok if {[catch {socket -server dodo 0x3000} msg]} { set x $msg @@ -709,10 +713,8 @@ test socket-4.2 {byte order problems, socket numbers, htons} { set x } ok -test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { - # - # THIS TEST WILL FAIL if you are running as superuser. - # +test socket-5.1 {byte order problems, socket numbers, htons} \ + {socket unixOnly notRoot} { set x {couldn't open socket: not owner} if {![catch {socket -server dodo 0x1} msg]} { set x {htons problem, should be disallowed, are you running as SU?} @@ -720,7 +722,7 @@ test socket-5.1 {byte order problems, socket numbers, htons} {unixOnly} { } set x } {couldn't open socket: not owner} -test socket-5.2 {byte order problems, socket numbers, htons} { +test socket-5.2 {byte order problems, socket numbers, htons} {socket} { set x {couldn't open socket: port number too high} if {![catch {socket -server dodo 0x10000} msg]} { set x {port resolution problem, should be disallowed} @@ -728,10 +730,8 @@ test socket-5.2 {byte order problems, socket numbers, htons} { } set x } {couldn't open socket: port number too high} -test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} { - # - # THIS TEST WILL FAIL if you are running as superuser. - # +test socket-5.3 {byte order problems, socket numbers, htons} \ + {socket unixOnly notRoot} { set x {couldn't open socket: not owner} if {![catch {socket -server dodo 21} msg]} { set x {htons problem, should be disallowed, are you running as SU?} @@ -740,12 +740,12 @@ test socket-5.3 {byte order problems, socket numbers, htons} {unixOnly} { set x } {couldn't open socket: not owner} -test socket-6.1 {accept callback error} {stdio} { +test socket-6.1 {accept callback error} {socket stdio} { removeFile script set f [open script w] puts $f { gets stdin - socket localhost 2848 + socket 127.0.0.1 2848 } close $f set f [open "|[list $tcltest script]" r+] @@ -765,7 +765,7 @@ test socket-6.1 {accept callback error} {stdio} { set x } {{divide by zero}} -test socket-7.1 {testing socket specific options} {stdio} { +test socket-7.1 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -782,7 +782,7 @@ test socket-7.1 {testing socket specific options} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2820] + set s [socket 127.0.0.1 2820] set p [fconfigure $s -peername] close $s close $f @@ -791,7 +791,7 @@ test socket-7.1 {testing socket specific options} {stdio} { lappend l [string compare [lindex $p 2] 2820] lappend l [llength $p] } {0 0 3} -test socket-7.2 {testing socket specific options} {stdio} { +test socket-7.2 {testing socket specific options} {socket stdio} { removeFile script set f [open script w] puts $f { @@ -808,7 +808,7 @@ test socket-7.2 {testing socket specific options} {stdio} { close $f set f [open "|[list $tcltest script]" r] gets $f - set s [socket localhost 2821] + set s [socket 127.0.0.1 2821] set p [fconfigure $s -sockname] close $s close $f @@ -817,14 +817,14 @@ test socket-7.2 {testing socket specific options} {stdio} { 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} { +test socket-7.3 {testing socket specific options} {socket} { set s [socket -server accept 2822] set l [fconfigure $s] close $s update llength $l -} 10 -test socket-7.4 {testing socket specific options} { +} 12 +test socket-7.4 {testing socket specific options} {socket} { set s [socket -server accept 2823] proc accept {s a p} { global x @@ -840,14 +840,14 @@ test socket-7.4 {testing socket specific options} { set l "" lappend l [lindex $x 2] [llength $x] } {2823 3} -test socket-7.5 {testing socket specific options} {unixOrPc} { +test socket-7.5 {testing socket specific options} {socket unixOrPc} { set s [socket -server accept 2829] proc accept {s a p} { global x set x [fconfigure $s -sockname] close $s } - set s1 [socket localhost 2829] + set s1 [socket 127.0.0.1 2829] set timer [after 10000 "set x timed_out"] vwait x after cancel $timer @@ -857,7 +857,7 @@ test socket-7.5 {testing socket specific options} {unixOrPc} { 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} { +test socket-8.1 {testing -async flag on sockets} {socket} { # NOTE: This test may fail on some Solaris 2.4 systems. If it does, # check that you have these patches installed (using showrev -p): # @@ -887,7 +887,7 @@ test socket-8.1 {testing -async flag on sockets} { set z } bye -test socket-9.1 {testing spurious events} { +test socket-9.1 {testing spurious events} {socket} { set len 0 set spurious 0 set done 0 @@ -919,7 +919,7 @@ test socket-9.1 {testing spurious events} { close $s list $spurious $len } {0 50} -test socket-9.2 {testing async write, fileevents, flush on close} {} { +test socket-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 "" @@ -967,7 +967,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} {} { close $l set count } 65566 -test socket-9.3 {testing EOF stickyness} { +test socket-9.3 {testing EOF stickyness} {socket} { proc count_to_eof {s} { global count done timer set l [gets $s] @@ -1007,30 +1007,21 @@ test socket-9.3 {testing EOF stickyness} { set count } {eof is sticky} -test socket-10.1 {testing socket accept callback error handling} { +removeFile script + +test socket-10.1 {testing socket accept callback error handling} {socket} { set goterror 0 proc bgerror args {global goterror; set goterror 1} set s [socket -server accept 2898] proc accept {s a p} {close $s; error} - set c [socket localhost 2898] + set c [socket 127.0.0.1 2898] vwait goterror close $s close $c set goterror } 1 -removeFile script - -# -# The rest of the tests are run only if we are doing testing against -# a remote server. -# - -if {$doTestsWithRemoteServer == 0} { - return -} - -test socket-11.1 {tcp connection} { +test socket-11.1 {tcp connection} {socket doTestsWithRemoteServer} { sendCommand { set socket9_1_test_server [socket -server accept 2834] proc accept {s a p} { @@ -1044,7 +1035,7 @@ test socket-11.1 {tcp connection} { sendCommand {close $socket9_1_test_server} set r } done -test socket-11.2 {client specifies its port} { +test socket-11.2 {client specifies its port} {socket doTestsWithRemoteServer} { if {[info exists port]} { incr port } else { @@ -1068,7 +1059,7 @@ test socket-11.2 {client specifies its port} { } set result } ok -test socket-11.3 {trying to connect, no server} { +test socket-11.3 {trying to connect, no server} {socket doTestsWithRemoteServer} { set status ok if {![catch {set s [socket $remoteServerIp 2836]}]} { if {![catch {gets $s}]} { @@ -1078,7 +1069,7 @@ test socket-11.3 {trying to connect, no server} { } set status } ok -test socket-11.4 {remote echo, one line} { +test socket-11.4 {remote echo, one line} {socket doTestsWithRemoteServer} { sendCommand { set socket10_6_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1102,7 +1093,7 @@ test socket-11.4 {remote echo, one line} { sendCommand {close $socket10_6_test_server} set r } hello -test socket-11.5 {remote echo, 50 lines} { +test socket-11.5 {remote echo, 50 lines} {socket doTestsWithRemoteServer} { sendCommand { set socket10_7_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1136,7 +1127,7 @@ if {$tcl_platform(platform) == "macintosh"} { } else { set conflictResult {1 {couldn't open socket: address already in use}} } -test socket-11.6 {socket conflict} { +test socket-11.6 {socket conflict} {socket doTestsWithRemoteServer} { set s1 [socket -server accept 2836] if {[catch {set s2 [socket -server accept 2836]} msg]} { set result [list 1 $msg] @@ -1147,7 +1138,7 @@ test socket-11.6 {socket conflict} { close $s1 set result } $conflictResult -test socket-11.7 {server with several clients} { +test socket-11.7 {server with several clients} {socket doTestsWithRemoteServer} { sendCommand { set socket10_9_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1183,7 +1174,7 @@ test socket-11.7 {server with several clients} { sendCommand {close $socket10_9_test_server} set i } 100 -test socket-11.8 {client with several servers} { +test socket-11.8 {client with several servers} {socket doTestsWithRemoteServer} { sendCommand { set s1 [socket -server "accept 4003" 4003] set s2 [socket -server "accept 4004" 4004] @@ -1209,7 +1200,7 @@ test socket-11.8 {client with several servers} { } set l } {4003 {} 1 4004 {} 1 4005 {} 1} -test socket-11.9 {accept callback error} { +test socket-11.9 {accept callback error} {socket doTestsWithRemoteServer} { set s [socket -server accept 2836] proc accept {s a p} {expr 10 / 0} proc bgerror args { @@ -1231,7 +1222,7 @@ test socket-11.9 {accept callback error} { rename bgerror {} set x } {{divide by zero}} -test socket-11.10 {testing socket specific options} { +test socket-11.10 {testing socket specific options} {socket doTestsWithRemoteServer} { sendCommand { set socket10_12_test_server [socket -server accept 2836] proc accept {s a p} {close $s} @@ -1245,7 +1236,7 @@ test socket-11.10 {testing socket specific options} { sendCommand {close $socket10_12_test_server} set l } {2836 3 3} -test socket-11.11 {testing spurious events} { +test socket-11.11 {testing spurious events} {socket doTestsWithRemoteServer} { sendCommand { set socket10_13_test_server [socket -server accept 2836] proc accept {s a p} { @@ -1284,7 +1275,7 @@ test socket-11.11 {testing spurious events} { sendCommand {close $socket10_13_test_server} list $spurious $len } {0 2690} -test socket-11.12 {testing EOF stickyness} { +test socket-11.12 {testing EOF stickyness} {socket doTestsWithRemoteServer} { set counter 0 set done 0 proc count_up {s} { @@ -1317,7 +1308,8 @@ test socket-11.12 {testing EOF stickyness} { sendCommand {close $socket10_14_test_server} set done } {EOF is sticky} -test socket-11.13 {testing async write, async flush, async close} { +test socket-11.13 {testing async write, async flush, async close} \ + {socket doTestsWithRemoteServer} { proc readit {s} { global count done set l [read $s] @@ -1370,7 +1362,8 @@ test socket-11.13 {testing async write, async flush, async close} { set count } 65566 -test socket-12.1 {testing inheritance of server sockets} { +test socket-12.1 {testing inheritance of server sockets} \ + {socket doTestsWithRemoteServer} { removeFile script1 removeFile script2 @@ -1410,7 +1403,7 @@ test socket-12.1 {testing inheritance of server sockets} { # If we can still connect to the server, the socket got inherited. - if {[catch {socket localhost 2828} msg]} { + if {[catch {socket 127.0.0.1 2828} msg]} { set x {server socket was not inherited} } else { close $msg @@ -1421,7 +1414,8 @@ test socket-12.1 {testing inheritance of server sockets} { removeFile script2 set x } {server socket was not inherited} -test socket-12.2 {testing inheritance of client sockets} { +test socket-12.2 {testing inheritance of client sockets} \ + {socket doTestsWithRemoteServer} { removeFile script1 removeFile script2 @@ -1442,7 +1436,7 @@ test socket-12.2 {testing inheritance of client sockets} { set f [open script2 w] puts $f [list set tcltest $tcltest] puts $f { - set f [socket localhost 2829] + set f [socket 127.0.0.1 2829] exec $tcltest script1 & puts $f testing flush $f @@ -1506,7 +1500,8 @@ test socket-12.2 {testing inheritance of client sockets} { removeFile script2 set x } {client socket was not inherited} -test socket-12.3 {testing inheritance of accepted sockets} { +test socket-12.3 {testing inheritance of accepted sockets} \ + {socket doTestsWithRemoteServer} { removeFile script1 removeFile script2 @@ -1539,7 +1534,7 @@ test socket-12.3 {testing inheritance of accepted sockets} { after 1000 set ok_to_proceed 1 vwait ok_to_proceed - set f [socket localhost 2930] + set f [socket 127.0.0.1 2930] fconfigure $f -buffering full -blocking 0 fileevent $f readable [list getdata $f] @@ -1581,13 +1576,94 @@ test socket-12.3 {testing inheritance of accepted sockets} { set x } {accepted socket was not inherited} +test socket-13.1 {Testing use of shared socket between two threads} \ + {socket testthread} { + + set mainthread [testthread names] + proc ThreadReap {} { + global mainthread + testthread errorproc ThreadNullError + while {[llength [testthread names]] > 1} { + foreach tid [testthread names] { + if {$tid != $mainthread} { + catch {testthread send -async $tid {testthread exit}} + update + } + } + } + testthread errorproc ThreadError + return [llength [testthread names]] + } + + removeFile script + set f [open script w] + puts $f { + set f [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 + } + close $f + + # create a thread + set serverthread [testthread create { source script } ] + update + + + set s [socket 127.0.0.1 2828] + fconfigure $s -buffering line + catch { + puts $s "hello" + gets $s result + } + close $s + update + + after 2000 + ThreadReap + + set result + +} hello + +# cleanup if {[string match sock* $commandSocket] == 1} { puts $commandSocket exit flush $commandSocket } catch {close $commandSocket} catch {close $remoteProcChan} +::tcltest::cleanupTests +flush stdout +return + + + + + + + + + + -set x "" -unset x |