diff options
Diffstat (limited to 'tests/socket.test')
| -rw-r--r-- | tests/socket.test | 101 |
1 files changed, 53 insertions, 48 deletions
diff --git a/tests/socket.test b/tests/socket.test index f5c75b1..172a46b 100644 --- a/tests/socket.test +++ b/tests/socket.test @@ -10,7 +10,7 @@ # 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.23 2002/04/15 23:09:12 dgp Exp $ +# RCS: @(#) $Id: socket.test,v 1.24 2002/07/04 20:06:13 andreas_kupries Exp $ # Running socket tests with a remote server: # ------------------------------------------ @@ -248,9 +248,11 @@ test socket-1.12 {arg parsing for socket command} {socket} { list [catch {socket foo badport} msg] $msg } {1 {expected integer but got "badport"}} +set path(script) [makeFile {} script] + test socket-2.1 {tcp connection} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timed_out"] set f [socket -server accept 0] @@ -267,7 +269,7 @@ test socket-2.1 {tcp connection} {socket stdio} { puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen if {[catch {socket 127.0.0.1 $listen} msg]} { @@ -288,7 +290,7 @@ if [info exists port] { } test socket-2.2 {tcp connection with client port specified} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] set f [socket -server accept 0] @@ -305,7 +307,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} { close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen global port @@ -324,7 +326,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} { } [list ready "hello $port"] test socket-2.3 {tcp connection with client interface specified} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] set f [socket -server accept 2830] @@ -340,7 +342,7 @@ test socket-2.3 {tcp connection with client interface specified} {socket stdio} close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x if {[catch {socket -myaddr 127.0.0.1 127.0.0.1 2830} sock]} { set x $sock @@ -355,7 +357,7 @@ test socket-2.3 {tcp connection with client interface specified} {socket stdio} } {ready {hello 127.0.0.1}} test socket-2.4 {tcp connection with server interface specified} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 2000 "set x done"] set f [socket -server accept -myaddr [info hostname] 0] @@ -372,7 +374,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio} close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen if {[catch {socket [info hostname] $listen} sock]} { @@ -388,7 +390,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio} } {ready hello} test socket-2.5 {tcp connection with redundant server port} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] set f [socket -server accept 0] @@ -405,7 +407,7 @@ test socket-2.5 {tcp connection with redundant server port} {socket stdio} { close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f x gets $f listen if {[catch {socket 127.0.0.1 $listen} sock]} { @@ -431,7 +433,7 @@ test socket-2.6 {tcp connection} {socket} { } ok test socket-2.7 {echo server, one line} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set timer [after 10000 "set x timeout"] set f [socket -server accept 0] @@ -457,7 +459,7 @@ test socket-2.7 {echo server, one line} {socket stdio} { puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -498,7 +500,7 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { close $f puts "done $i" } script - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -517,10 +519,10 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} { test socket-2.9 {socket conflict} {socket stdio} { set s [socket -server accept 0] removeFile script - set f [open script w] + set f [open $path(script) w] puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]" close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f after 100 set x [list [catch {close $f} msg]] @@ -583,7 +585,7 @@ test socket-2.11 {detecting new data} {socket} { test socket-3.1 {socket conflict} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set f [socket -server accept 0] puts ready @@ -592,7 +594,7 @@ test socket-3.1 {socket conflict} {socket stdio} { close $f } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest $path(script)]" r+] gets $f gets $f listen set x [list [catch {socket -server accept $listen} msg] \ @@ -603,7 +605,7 @@ test socket-3.1 {socket conflict} {socket stdio} { } {1 {couldn't open socket: address already in use}} test socket-3.2 {server with several clients} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set t1 [after 30000 "set x timed_out"] set t2 [after 31000 "set x timed_out"] @@ -636,7 +638,7 @@ test socket-3.2 {server with several clients} {socket stdio} { puts $x } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest $path(script)]" r+] set x [gets $f] gets $f listen set s1 [socket 127.0.0.1 $listen] @@ -663,7 +665,7 @@ test socket-3.2 {server with several clients} {socket stdio} { test socket-4.1 {server with several clients} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set port [gets stdin] set s [socket 127.0.0.1 $port] @@ -677,11 +679,11 @@ test socket-4.1 {server with several clients} {socket stdio} { gets stdin } close $f - set p1 [open "|[list $::tcltest::tcltest script]" r+] + set p1 [open "|[list $::tcltest::tcltest $path(script)]" r+] fconfigure $p1 -buffering line - set p2 [open "|[list $::tcltest::tcltest script]" r+] + set p2 [open "|[list $::tcltest::tcltest $path(script)]" r+] fconfigure $p2 -buffering line - set p3 [open "|[list $::tcltest::tcltest script]" r+] + set p3 [open "|[list $::tcltest::tcltest $path(script)]" r+] fconfigure $p3 -buffering line proc accept {s a p} { fconfigure $s -buffering line @@ -763,13 +765,13 @@ test socket-5.3 {byte order problems, socket numbers, htons} \ test socket-6.1 {accept callback error} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { gets stdin port socket 127.0.0.1 $port } close $f - set f [open "|[list $::tcltest::tcltest script]" r+] + set f [open "|[list $::tcltest::tcltest $path(script)]" r+] proc bgerror args { global x set x $args @@ -788,7 +790,7 @@ test socket-6.1 {accept callback error} {socket stdio} { test socket-7.1 {testing socket specific options} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set ss [socket -server accept 0] proc accept args { @@ -802,7 +804,7 @@ test socket-7.1 {testing socket specific options} {socket stdio} { after cancel $timer } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -816,7 +818,7 @@ test socket-7.1 {testing socket specific options} {socket stdio} { } {0 0 3} test socket-7.2 {testing socket specific options} {socket stdio} { removeFile script - set f [open script w] + set f [open $path(script) w] puts $f { set ss [socket -server accept 2821] proc accept args { @@ -830,7 +832,7 @@ test socket-7.2 {testing socket specific options} {socket stdio} { after cancel $timer } close $f - set f [open "|[list $::tcltest::tcltest script]" r] + set f [open "|[list $::tcltest::tcltest $path(script)]" r] gets $f gets $f listen set s [socket 127.0.0.1 $listen] @@ -1390,6 +1392,9 @@ test socket-11.13 {testing async write, async flush, async close} \ set count } 65566 +set path(script1) [makeFile {} script1] +set path(script2) [makeFile {} script2] + test socket-12.1 {testing inheritance of server sockets} {socket exec} { removeFile script1 removeFile script2 @@ -1397,7 +1402,7 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} { # 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] + set f [open $path(script1) w] puts $f { after 10000 exit vwait forever @@ -1408,25 +1413,25 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} { # waits a second, and exits. The server socket will now # be closed unless script1 inherited it. - set f [open script2 w] + set f [open $path(script2) w] puts $f [list set tcltest $::tcltest::tcltest] - puts $f { + puts $f [format { set f [socket -server accept 0] puts [lindex [fconfigure $f -sockname] 2] proc accept { file addr port } { close $file } - exec $tcltest script1 & + exec $tcltest "%s" & close $f after 1000 exit vwait forever - } + } $path(script1)] close $f # Launch script2 and wait 5 seconds ### exec $::tcltest::tcltest script2 & - set p [open "|[list $::tcltest::tcltest script2]" r] + set p [open "|[list $::tcltest::tcltest $path(script2)]" r] gets $p listen after 5000 { set ok_to_proceed 1 } @@ -1453,7 +1458,7 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} { # Script1 is just a 20 second delay. If the server socket # is inherited, it will be held open for 10 seconds - set f [open script1 w] + set f [open $path(script1) w] puts $f { after 20000 exit vwait forever @@ -1464,17 +1469,17 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} { # launches script1 and exits. If the child process inherited the # client socket, the socket will still be open. - set f [open script2 w] + set f [open $path(script2) w] puts $f [list set tcltest $::tcltest::tcltest] - puts $f { + puts $f [format { gets stdin port set f [socket 127.0.0.1 $port] - exec $tcltest script1 & + exec $tcltest "%s" & puts $f testing flush $f after 1000 exit vwait forever - } + } $path(script1)] close $f # Create the server socket @@ -1521,7 +1526,7 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} { # Launch the script2 process ### exec $::tcltest::tcltest script2 & - set p [open "|[list $::tcltest::tcltest script2]" w] + set p [open "|[list $::tcltest::tcltest $path(script2)]" w] puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p vwait x @@ -1537,33 +1542,33 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket exec} { removeFile script1 removeFile script2 - set f [open script1 w] + set f [open $path(script1) w] puts $f { after 10000 exit vwait forever } close $f - set f [open script2 w] + set f [open $path(script2) w] puts $f [list set tcltest $::tcltest::tcltest] - puts $f { + puts $f [format { set server [socket -server accept 0] puts stdout [lindex [fconfigure $server -sockname] 2] proc accept { file host port } { global tcltest puts $file {test data on socket} - exec $tcltest script1 & + exec $tcltest "%s" & after 1000 exit } vwait forever - } + } $path(script1)] close $f # Launch the script2 process and connect to it. See how long # the socket stays open ## exec $::tcltest::tcltest script2 & - set p [open "|[list $::tcltest::tcltest script2]" r] + set p [open "|[list $::tcltest::tcltest $path(script2)]" r] gets $p listen after 1000 set ok_to_proceed 1 |