summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog3
-rw-r--r--tests/socket.test56
2 files changed, 30 insertions, 29 deletions
diff --git a/ChangeLog b/ChangeLog
index 13df024..e46dc8b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -7,6 +7,9 @@
tests to dynamically adapt to the address family that is being
tested.
+ Rework some of the tests to speed them up by avoiding (supposedly)
+ unneeded [after]s.
+
2010-11-04 Stuart Cassoff <stwo@users.sourceforge.net>
* unix/Makefile.in: [Patch 3101127]: Installer Improvements.
* unix/install-sh:
diff --git a/tests/socket.test b/tests/socket.test
index 46b4601..c937b7b 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.46 2010/11/04 15:59:23 rmax Exp $
+# RCS: @(#) $Id: socket.test,v 1.47 2010/11/04 18:39:31 rmax Exp $
# Running socket tests with a remote server:
# ------------------------------------------
@@ -92,6 +92,14 @@ if {![info exists remoteServerPort]} {
}
}
+if 0 {
+ # activate this to time the tests
+ proc test {args} {
+ set name [lindex $args 0]
+ puts "[lindex [time {uplevel [linsert $args 0 tcltest::test]}] 0] @@@ $name"
+ }
+}
+
foreach {af localhost} {
any 127.0.0.1
inet 127.0.0.1
@@ -464,7 +472,6 @@ test socket_$af-2.7 {echo server, one line} -constraints [list socket supported_
set s [socket $localhost $listen]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
- after 1000
set x [gets $s]
close $s
list $x [gets $f]
@@ -571,14 +578,16 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a
vwait sock
puts $s2 one
flush $s2
- after 500
+ after idle {set x 1}
+ vwait x
fconfigure $sock -blocking 0
set result a:[gets $sock]
lappend result b:[gets $sock]
fconfigure $sock -blocking 1
puts $s2 two
flush $s2
- after 500
+ after idle {set x 1}
+ vwait x
fconfigure $sock -blocking 0
lappend result c:[gets $sock]
} -cleanup {
@@ -980,12 +989,12 @@ test socket_$af-9.2 {testing async write, fileevents, flush on close} -constrain
proc readable {s} {
set l [gets $s]
fileevent $s readable {}
- after 1000 respond $s
+ after idle respond $s
}
proc respond {s} {
global firstblock
puts -nonewline $s $firstblock
- after 1000 writedata $s
+ after idle writedata $s
}
proc writedata {s} {
global secondblock
@@ -1392,12 +1401,12 @@ test socket_$af-11.13 {testing async write, async flush, async close} -setup {
proc readable {s} {
set l [gets $s]
fileevent $s readable {}
- after 1000 respond $s
+ after idle respond $s
}
proc respond {s} {
global firstblock
puts -nonewline $s $firstblock
- after 1000 writedata $s
+ after idle writedata $s
}
proc writedata {s} {
global secondblock
@@ -1443,31 +1452,27 @@ test socket_$af-12.1 {testing inheritance of server sockets} -setup {
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.
+ # Script2 creates the server socket, launches script1, and exits.
+ # The server socket will now be closed unless script1 inherited it.
set f [open $path(script2) w]
puts $f [list set tcltest [interpreter]]
puts $f [list set delay $path(script1)]
puts $f [list set localhost $localhost]
puts $f {
set f [socket -server accept -myaddr $localhost 0]
- puts [lindex [fconfigure $f -sockname] 2]
proc accept { file addr port } {
close $file
}
exec $tcltest $delay &
+ puts [lindex [fconfigure $f -sockname] 2]
close $f
- after 1000 exit
- vwait forever
+ exit
}
close $f
} -constraints [list socket supported_$af stdio exec] -body {
# Launch script2 and wait 5 seconds
### exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
- gets $p listen
- 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 {close [socket $localhost $listen]}]} {
return {server socket was not inherited}
@@ -1475,7 +1480,7 @@ test socket_$af-12.1 {testing inheritance of server sockets} -setup {
return {server socket was inherited}
}
} -cleanup {
- close $p
+ catch {close $p}
} -result {server socket was not inherited}
test socket_$af-12.2 {testing inheritance of client sockets} -setup {
file delete $path(script1)
@@ -1501,14 +1506,13 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
exec $tcltest $delay &
puts $f testing
flush $f
- after 1000 exit
- vwait forever
+ exit
}
close $f
# If the socket doesn't hit end-of-file in 10 seconds, the script1 process
# must have inherited the client.
set failed 0
- after 10000 [list set failed 1]
+ set after [after 10000 [list set failed 1]]
} -constraints [list socket supported_$af stdio exec] -body {
# Create the server socket
set server [socket -server accept -myaddr $localhost 0]
@@ -1547,9 +1551,7 @@ test socket_$af-12.2 {testing inheritance of client sockets} -setup {
vwait x
return $x
} -cleanup {
- if {!$failed} {
- vwait failed
- }
+ after cancel $after
close $p
} -result {client socket was not inherited}
test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
@@ -1567,13 +1569,13 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
puts $f [list set localhost $localhost]
puts $f {
set server [socket -server accept -myaddr $localhost 0]
- puts stdout [lindex [fconfigure $server -sockname] 2]
proc accept { file host port } {
global tcltest delay
puts $file {test data on socket}
exec $tcltest $delay &
- after 1000 exit
+ after idle exit
}
+ puts stdout [lindex [fconfigure $server -sockname] 2]
vwait forever
}
close $f
@@ -1583,8 +1585,6 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
## exec [interpreter] script2 &
set p [open "|[list [interpreter] $path(script2)]" r]
gets $p listen
- after 1000 set ok_to_proceed 1
- vwait ok_to_proceed
set f [socket $localhost $listen]
fconfigure $f -buffering full -blocking 0
fileevent $f readable [list getdata $f]
@@ -1654,7 +1654,6 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
update
set port [testthread send $serverthread {set listen}]
update
- after 1000
set s [socket $localhost $port]
fconfigure $s -buffering line
catch {
@@ -1663,7 +1662,6 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
}
close $s
update
- after 2000
append result " " [threadReap]
} -cleanup {
removeFile script