summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authorrmax <rmax>2010-09-28 15:13:54 (GMT)
committerrmax <rmax>2010-09-28 15:13:54 (GMT)
commit8de390107eb243b132d238c82d5dad142732ea6f (patch)
tree3c49ea8f056c9653ddd2cfed43ac4615cba322bb /tests
parent76ae3756ac54d0957e5d6c430aec55b52ccc0bf3 (diff)
downloadtcl-8de390107eb243b132d238c82d5dad142732ea6f.zip
tcl-8de390107eb243b132d238c82d5dad142732ea6f.tar.gz
tcl-8de390107eb243b132d238c82d5dad142732ea6f.tar.bz2
* doc/socket.n: Document the changes to the [socket] and
[fconfiguyre] commands. * generic/tclInt.h: Introduce TclCreateSocketAddress() as a * generic/tclIOSock.c: replacement for the platform-dependent * unix/tclUnixSock.c: TclpCreateSocketAddress() functions. * unix/tclUnixChan.c: Extend the [socket] and [fconfigure] * unix/tclUnixPort.h: commands to behave as proposed in * win/tclWinSock.c: TIP #162. * win/tclWinPort.h: * compat/fake-rfc2553.c: A compat implementation of the APIs * compat/fake-rfc2553.h: defined in RFC-2553 (getaddrinfo() and friends) on top of the existing gethostbyname() etc. * unix/configure.in: Test whether the fake-implementation is * unix/tcl.m4: needed. * unix/Makefile.in: Add a compile target for fake-rfc2553. * win/configure.in: Allow cross-compilation by default * tests/socket.test: Improve the test suite to make more use of * tests/remote.tcl: randomized ports to reduce interference with tests running in parallel or other services on the machine.
Diffstat (limited to 'tests')
-rw-r--r--tests/remote.tcl44
-rw-r--r--tests/socket.test198
2 files changed, 119 insertions, 123 deletions
diff --git a/tests/remote.tcl b/tests/remote.tcl
index 005f2df..fd50b51 100644
--- a/tests/remote.tcl
+++ b/tests/remote.tcl
@@ -9,7 +9,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: remote.tcl,v 1.3 1999/04/16 00:47:33 stanton Exp $
+# RCS: @(#) $Id: remote.tcl,v 1.4 2010/09/28 15:13:55 rmax Exp $
# Initialize message delimitor
@@ -32,11 +32,9 @@ proc __doCommands__ {l s} {
puts "---"
}
set callerSocket $s
- if {[catch {uplevel #0 $l} msg]} {
- list error $msg
- } else {
- list success $msg
- }
+ set ::errorInfo ""
+ set code [catch {uplevel "#0" $l} msg]
+ return [list $code $::errorInfo $msg]
}
proc __readAndExecute__ {s} {
@@ -44,10 +42,9 @@ proc __readAndExecute__ {s} {
set l [gets $s]
if {[string compare $l "--Marker--Marker--Marker--"] == 0} {
- if {[info exists command($s)]} {
- puts $s [list error incomplete_command]
- }
+ puts $s [__doCommands__ $command($s) $s]
puts $s "--Marker--Marker--Marker--"
+ set command($s) ""
return
}
if {[string compare $l ""] == 0} {
@@ -59,28 +56,26 @@ proc __readAndExecute__ {s} {
}
return
}
- append command($s) $l "\n"
- if {[info complete $command($s)]} {
- set cmds $command($s)
- unset command($s)
- puts $s [__doCommands__ $cmds $s]
- }
if {[eof $s]} {
if {$VERBOSE} {
puts "Server closing $s, eof from client"
}
close $s
+ unset command($s)
+ return
}
+ append command($s) $l "\n"
}
proc __accept__ {s a p} {
- global VERBOSE
+ global command VERBOSE
if {$VERBOSE} {
puts "Server accepts new connection from $a:$p on $s"
}
- fileevent $s readable [list __readAndExecute__ $s]
+ set command($s) ""
fconfigure $s -buffering line -translation crlf
+ fileevent $s readable [list __readAndExecute__ $s]
}
set serverIsSilent 0
@@ -153,20 +148,13 @@ if {$serverIsSilent == 0} {
flush stdout
}
+proc getPort sock {
+ lindex [fconfigure $sock -sockname] 2
+}
+
if {[catch {set serverSocket \
[socket -myaddr $serverAddress -server __accept__ $serverPort]} msg]} {
puts "Server on $serverAddress:$serverPort cannot start: $msg"
} else {
vwait __server_wait_variable__
}
-
-
-
-
-
-
-
-
-
-
-
diff --git a/tests/socket.test b/tests/socket.test
index 99ce29f..6e92afd 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.43 2010/06/25 15:20:06 rmax Exp $
+# RCS: @(#) $Id: socket.test,v 1.44 2010/09/28 15:13:55 rmax Exp $
# Running socket tests with a remote server:
# ------------------------------------------
@@ -69,6 +69,10 @@ namespace import -force ::tcltest::*
testConstraint testthread [llength [info commands testthread]]
testConstraint exec [llength [info commands exec]]
+# Produce a random port number in the Dynamic/Private range
+# from 49152 through 65535.
+proc randport {} { expr {int(rand()*16383+49152)} }
+
# If remoteServerIP or remoteServerPort are not set, check in the environment
# variables for externally set values.
#
@@ -79,7 +83,7 @@ if {![info exists remoteServerIP]} {
}
}
if {![info exists remoteServerPort]} {
- if {[info exists env(remoteServerIP)]} {
+ if {[info exists env(remoteServerPort)]} {
set remoteServerPort $env(remoteServerPort)
} else {
if {[info exists remoteServerIP]} {
@@ -97,7 +101,7 @@ if {![info exists remoteServerIP]} {
set remoteServerIP 127.0.0.1
}
if {($doTestsWithRemoteServer == 1) && (![info exists remoteServerPort])} {
- set remoteServerPort 2048
+ set remoteServerPort [randport]
}
# Attempt to connect to a remote server if one is already running. If it is
@@ -173,24 +177,24 @@ if {[testConstraint doTestsWithRemoteServer]} {
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"
+ if {$line eq "--Marker--Marker--Marker--"} {
+ lassign $result code info value
+ return -code $code -errorinfo $info $value
}
+ append result $line "\n"
}
}
}
+
+proc getPort sock {
+ lindex [fconfigure $sock -sockname] 2
+}
+
# ----------------------------------------------------------------------
@@ -270,12 +274,8 @@ test socket-2.1 {tcp connection} -constraints {socket stdio} -setup {
} -cleanup {
close $f
} -result {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} -setup {
+ set port [randport]
file delete $path(script)
set f [open $path(script) w]
puts $f {
@@ -299,29 +299,29 @@ test socket-2.2 {tcp connection with client port specified} -setup {
gets $f listen
} -constraints {socket stdio} -body {
# $x == "ready" at this point
- global port
set sock [socket -myport $port 127.0.0.1 $listen]
puts $sock hello
flush $sock
- lappend x [gets $f]
+ lappend x [expr {[gets $f] eq "hello $port"}]
close $sock
return $x
} -cleanup {
catch {close [socket 127.0.0.1 $listen]}
close $f
-} -result [list ready "hello $port"]
+} -result {ready 1}
test socket-2.3 {tcp connection with client interface specified} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept 2830]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $addr"
close $file
set x done
}
+ puts [lindex [fconfigure $f -sockname] 2]
puts ready
vwait x
after cancel $timer
@@ -329,10 +329,11 @@ test socket-2.3 {tcp connection with client interface specified} -setup {
}
close $f
set f [open "|[list [interpreter] $path(script)]" r]
+ gets $f listen
gets $f x
} -constraints {socket stdio} -body {
# $x == "ready" at this point
- set sock [socket -myaddr 127.0.0.1 127.0.0.1 2830]
+ set sock [socket -myaddr 127.0.0.1 127.0.0.1 $listen]
puts $sock hello
flush $sock
lappend x [gets $f]
@@ -409,7 +410,7 @@ test socket-2.5 {tcp connection with redundant server port} -setup {
} -result {ready hello}
test socket-2.6 {tcp connection} -constraints socket -body {
set status ok
- if {![catch {set sock [socket 127.0.0.1 2833]}]} {
+ if {![catch {set sock [socket 127.0.0.1 [randport]]}]} {
if {![catch {gets $sock}]} {
set status broken
}
@@ -810,7 +811,7 @@ test socket-7.2 {testing socket specific options} -setup {
file delete $path(script)
set f [open $path(script) w]
puts $f {
- set ss [socket -server accept 2821]
+ set ss [socket -server accept 0]
proc accept args {
global x
set x done
@@ -1061,44 +1062,42 @@ test socket-10.1 {testing socket accept callback error handling} -constraints {
} -result 1
test socket-11.1 {tcp connection} -setup {
- sendCommand {
- set socket9_1_test_server [socket -server accept 2834]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
puts $s done
close $s
}
- }
+ getPort $server
+ }]
} -constraints {socket doTestsWithRemoteServer} -body {
- set s [socket $remoteServerIP 2834]
+ set s [socket $remoteServerIP $port]
gets $s
} -cleanup {
close $s
- sendCommand {close $socket9_1_test_server}
+ sendCommand {close $server}
} -result done
test socket-11.2 {client specifies its port} -setup {
- if {[info exists port]} {
- incr port
- } else {
- set port [expr 2048 + [pid]%1024]
- }
- sendCommand {
- set socket9_2_test_server [socket -server accept 2835]
+ set lport [randport]
+ set rport [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
puts $s $p
close $s
}
- }
+ getPort $server
+ }]
} -constraints {socket doTestsWithRemoteServer} -body {
- set s [socket -myport $port $remoteServerIP 2835]
+ set s [socket -myport $lport $remoteServerIP $rport]
set r [gets $s]
- expr {$r==$port ? "ok" : "broken: $r != $port"}
+ expr {$r==$lport ? "ok" : "broken: $r != $port"}
} -cleanup {
close $s
- sendCommand {close $socket9_2_test_server}
+ sendCommand {close $server}
} -result ok
test socket-11.3 {trying to connect, no server} -body {
set status ok
- if {![catch {set s [socket $remoteServerIp 2836]}]} {
+ if {![catch {set s [socket $remoteServerIp [randport]]}]} {
if {![catch {gets $s}]} {
set status broken
}
@@ -1107,8 +1106,8 @@ test socket-11.3 {trying to connect, no server} -body {
return $status
} -constraints {socket doTestsWithRemoteServer} -result ok
test socket-11.4 {remote echo, one line} -setup {
- sendCommand {
- set socket10_6_test_server [socket -server accept 2836]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
@@ -1121,19 +1120,20 @@ test socket-11.4 {remote echo, one line} -setup {
puts $s $l
}
}
- }
+ getPort $server
+ }]
} -constraints {socket doTestsWithRemoteServer} -body {
- set f [socket $remoteServerIP 2836]
+ set f [socket $remoteServerIP $port]
fconfigure $f -translation crlf -buffering line
puts $f hello
gets $f
} -cleanup {
catch {close $f}
- sendCommand {close $socket10_6_test_server}
+ sendCommand {close $server}
} -result hello
test socket-11.5 {remote echo, 50 lines} -setup {
- sendCommand {
- set socket10_7_test_server [socket -server accept 2836]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line -translation crlf
@@ -1146,9 +1146,10 @@ test socket-11.5 {remote echo, 50 lines} -setup {
puts $s $l
}
}
- }
+ getPort $server
+ }]
} -constraints {socket doTestsWithRemoteServer} -body {
- set f [socket $remoteServerIP 2836]
+ set f [socket $remoteServerIP $port]
fconfigure $f -translation crlf -buffering line
for {set cnt 0} {$cnt < 50} {incr cnt} {
puts $f "hello, $cnt"
@@ -1159,19 +1160,19 @@ test socket-11.5 {remote echo, 50 lines} -setup {
return $cnt
} -cleanup {
close $f
- sendCommand {close $socket10_7_test_server}
+ sendCommand {close $server}
} -result 50
test socket-11.6 {socket conflict} -setup {
- set s1 [socket -server accept -myaddr 127.0.0.1 2836]
+ set s1 [socket -server accept -myaddr 127.0.0.1 0]
} -constraints {socket doTestsWithRemoteServer} -body {
- set s2 [socket -server accept -myaddr 127.0.0.1 2836]
- list [lindex [fconfigure $s2 -sockname] 2] [close $s2]
+ set s2 [socket -server accept -myaddr 127.0.0.1 [getPort $s1]]
+ list [getPort $s2] [close $s2]
} -cleanup {
close $s1
} -returnCodes error -result {couldn't open socket: address already in use}
test socket-11.7 {server with several clients} -setup {
- sendCommand {
- set socket10_9_test_server [socket -server accept 2836]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -buffering line
fileevent $s readable [list echo $s]
@@ -1184,13 +1185,14 @@ test socket-11.7 {server with several clients} -setup {
puts $s $l
}
}
- }
+ getPort $server
+ }]
} -constraints {socket doTestsWithRemoteServer} -body {
- set s1 [socket $remoteServerIP 2836]
+ set s1 [socket $remoteServerIP $port]
fconfigure $s1 -buffering line
- set s2 [socket $remoteServerIP 2836]
+ set s2 [socket $remoteServerIP $port]
fconfigure $s2 -buffering line
- set s3 [socket $remoteServerIP 2836]
+ set s3 [socket $remoteServerIP $port]
fconfigure $s3 -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s1 hello,s1
@@ -1205,22 +1207,23 @@ test socket-11.7 {server with several clients} -setup {
close $s1
close $s2
close $s3
- sendCommand {close $socket10_9_test_server}
+ sendCommand {close $server}
} -result 100
test socket-11.8 {client with several servers} -setup {
- sendCommand {
- set s1 [socket -server "accept 4003" 4003]
- set s2 [socket -server "accept 4004" 4004]
- set s3 [socket -server "accept 4005" 4005]
+ lassign [sendCommand {
+ set s1 [socket -server "accept server1" 0]
+ set s2 [socket -server "accept server2" 0]
+ set s3 [socket -server "accept server3" 0]
proc accept {mp s a p} {
puts $s $mp
close $s
}
- }
+ list [getPort $s1] [getPort $s2] [getPort $s3]
+ }] p1 p2 p3
} -constraints {socket doTestsWithRemoteServer} -body {
- set s1 [socket $remoteServerIP 4003]
- set s2 [socket $remoteServerIP 4004]
- set s3 [socket $remoteServerIP 4005]
+ set s1 [socket $remoteServerIP $p1]
+ set s2 [socket $remoteServerIP $p2]
+ set s3 [socket $remoteServerIP $p3]
list [gets $s1] [gets $s1] [eof $s1] [gets $s2] [gets $s2] [eof $s2] \
[gets $s3] [gets $s3] [eof $s3]
} -cleanup {
@@ -1232,7 +1235,7 @@ test socket-11.8 {client with several servers} -setup {
close $s2
close $s3
}
-} -result {4003 {} 1 4004 {} 1 4005 {} 1}
+} -result {server1 {} 1 server2 {} 1 server3 {} 1}
test socket-11.9 {accept callback error} -constraints {
socket doTestsWithRemoteServer
} -setup {
@@ -1243,12 +1246,13 @@ test socket-11.9 {accept callback error} -constraints {
interp bgerror {} [namespace which myHandler]
set timer [after 10000 "set x timed_out"]
} -body {
- set s [socket -server accept 2836]
- proc accept {s a p} {expr 10 / 0}
+ set s [socket -server accept 0]
+ proc accept {s a p} {expr {10 / 0}}
+ sendCommand "set port [getPort $s]"
if {[catch {
sendCommand {
set peername [fconfigure $callerSocket -peername]
- set s [socket [lindex $peername 0] 2836]
+ set s [socket [lindex $peername 0] $port]
close $s
}
} msg]} then {
@@ -1263,22 +1267,23 @@ test socket-11.9 {accept callback error} -constraints {
interp bgerror {} $handler
} -result {divide by zero}
test socket-11.10 {testing socket specific options} -setup {
- sendCommand {
- set socket10_12_test_server [socket -server accept 2836]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {close $s}
- }
+ getPort $server
+ }]
} -constraints {socket doTestsWithRemoteServer} -body {
- set s [socket $remoteServerIP 2836]
+ set s [socket $remoteServerIP $port]
set p [fconfigure $s -peername]
set n [fconfigure $s -sockname]
- list [lindex $p 2] [llength $p] [llength $n]
+ list [expr {[lindex $p 2] == $port}] [llength $p] [llength $n]
} -cleanup {
close $s
- sendCommand {close $socket10_12_test_server}
-} -result {2836 3 3}
+ sendCommand {close $server}
+} -result {1 3 3}
test socket-11.11 {testing spurious events} -setup {
- sendCommand {
- set socket10_13_test_server [socket -server accept 2836]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -translation "auto lf"
after 100 writesome $s
@@ -1289,7 +1294,8 @@ test socket-11.11 {testing spurious events} -setup {
}
close $s
}
- }
+ getPort $server
+ }]
set len 0
set spurious 0
set done 0
@@ -1309,23 +1315,24 @@ test socket-11.11 {testing spurious events} -setup {
incr len [string length $l]
}
}
- set c [socket $remoteServerIP 2836]
+ set c [socket $remoteServerIP $port]
fileevent $c readable "readlittle $c"
vwait done
list $spurious $len $done
} -cleanup {
after cancel $timer
- sendCommand {close $socket10_13_test_server}
+ sendCommand {close $server}
} -result {0 2690 1}
test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemoteServer} -setup {
set counter 0
set done 0
- sendCommand {
- set socket10_14_test_server [socket -server accept 2836]
+ set port [sendCommand {
+ set server [socket -server accept 0]
proc accept {s a p} {
after 100 close $s
}
- }
+ getPort $server
+ }]
proc timed_out {} {
global c done
set done {timed_out, EOF is not sticky}
@@ -1344,16 +1351,16 @@ test socket-11.12 {testing EOF stickyness} -constraints {socket doTestsWithRemot
}
}
}
- set c [socket $remoteServerIP 2836]
+ set c [socket $remoteServerIP $port]
fileevent $c readable [list count_up $c]
vwait done
return $done
} -cleanup {
after cancel $after_id
- sendCommand {close $socket10_14_test_server}
+ sendCommand {close $server}
} -result {EOF is sticky}
test socket-11.13 {testing async write, async flush, async close} -setup {
- sendCommand {
+ set port [sendCommand {
set firstblock ""
for {set i 0} {$i < 5} {incr i} {
set firstblock "a$firstblock$firstblock"
@@ -1362,7 +1369,7 @@ test socket-11.13 {testing async write, async flush, async close} -setup {
for {set i 0} {$i < 16} {incr i} {
set secondblock "b$secondblock$secondblock"
}
- set l [socket -server accept 2845]
+ set l [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
-buffering line
@@ -1383,7 +1390,8 @@ test socket-11.13 {testing async write, async flush, async close} -setup {
puts -nonewline $s $secondblock
close $s
}
- }
+ getPort $l
+ }]
set timer [after 10000 "set done timed_out"]
} -constraints {socket doTestsWithRemoteServer} -body {
proc readit {s} {
@@ -1395,7 +1403,7 @@ test socket-11.13 {testing async write, async flush, async close} -setup {
set done 1
}
}
- set s [socket $remoteServerIP 2845]
+ set s [socket $remoteServerIP $port]
fconfigure $s -blocking 0 -trans lf -buffering line
set count 0
puts $s hello
@@ -1650,7 +1658,7 @@ removeFile script1
removeFile script2
# cleanup
-if {[string match sock* $commandSocket] == 1} {
+if {$remoteProcChan ne ""} {
catch {sendCommand exit}
}
catch {close $commandSocket}