diff --git a/tests/support/server.tcl b/tests/support/server.tcl index e10c350ff..b53abb2ef 100644 --- a/tests/support/server.tcl +++ b/tests/support/server.tcl @@ -79,7 +79,7 @@ proc is_alive config { proc ping_server {host port} { set retval 0 if {[catch { - set fd [socket $::host $::port] + set fd [socket $host $port] fconfigure $fd -translation binary puts $fd "PING\r\n" flush $fd @@ -101,6 +101,22 @@ proc ping_server {host port} { return $retval } +# Return 1 if the server at the specified addr is reachable by PING, otherwise +# returns 0. Performs a try every 50 milliseconds for the specified number +# of retries. +proc server_is_up {host port retrynum} { + after 10 ;# Use a small delay to make likely a first-try success. + set retval 0 + while {[incr retrynum -1]} { + if {[catch {ping_server $host $port} ping]} { + set ping 0 + } + if {$ping} {return 1} + after 50 + } + return 0 +} + # doesn't really belong here, but highly coupled to code in start_server proc tags {tags code} { set ::tags [concat $::tags $tags] @@ -191,23 +207,13 @@ proc start_server {options {code undefined}} { # check that the server actually started # ugly but tries to be as fast as possible... if {$::valgrind} {set retrynum 1000} else {set retrynum 100} - set serverisup 0 if {$::verbose} { puts -nonewline "=== ($tags) Starting server ${::host}:${::port} " } - after 10 if {$code ne "undefined"} { - while {[incr retrynum -1]} { - catch { - if {[ping_server $::host $::port]} { - set serverisup 1 - } - } - if {$serverisup} break - after 50 - } + set serverisup [server_is_up $::host $::port $retrynum] } else { set serverisup 1 } diff --git a/tests/support/util.tcl b/tests/support/util.tcl index c5a6853b3..3804f253b 100644 --- a/tests/support/util.tcl +++ b/tests/support/util.tcl @@ -312,3 +312,18 @@ proc csvstring s { proc roundFloat f { format "%.10g" $f } + +proc find_available_port start { + for {set j $start} {$j < $start+1024} {incr j} { + if {[catch { + set fd [socket 127.0.0.1 $j] + }]} { + return $j + } else { + close $fd + } + } + if {$j == $start+1024} { + error "Can't find a non busy port in the $start-[expr {$start+1023}] range." + } +} diff --git a/tests/test_helper.tcl b/tests/test_helper.tcl index a0badb879..062c318e5 100644 --- a/tests/test_helper.tcl +++ b/tests/test_helper.tcl @@ -164,21 +164,6 @@ proc cleanup {} { if {!$::quiet} {puts "OK"} } -proc find_available_port start { - for {set j $start} {$j < $start+1024} {incr j} { - if {[catch { - set fd [socket 127.0.0.1 $j] - }]} { - return $j - } else { - close $fd - } - } - if {$j == $start+1024} { - error "Can't find a non busy port in the $start-[expr {$start+1023}] range." - } -} - proc test_server_main {} { cleanup set tclsh [info nameofexecutable]