summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog13
-rw-r--r--tests/all.tcl6
-rw-r--r--tests/io.test42
-rw-r--r--tests/socket.test194
4 files changed, 155 insertions, 100 deletions
diff --git a/ChangeLog b/ChangeLog
index 9e5c18b..919e21c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2001-09-11 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * The changes below are a fix for [219253].
+
+ * tests/socket.test: Removed _most_ instances of hardwired port
+ numbers for listening sockets. Remaining are the ports in all
+ tests with constraint 'doTestsWithRemoteServer'. These seem to
+ be designed for a more controlled environment and are usually
+ skipped when running the testsuite.
+
+ * tests/io.test: Removed all instances of hardwired port numbers
+ for listening sockets.
+
2001-09-10 Jeff Hobbs <jeffh@ActiveState.com>
* generic/tclEvent.c (TclInExit): Corrected handling of tsd in
diff --git a/tests/all.tcl b/tests/all.tcl
index 7918117..628710e 100644
--- a/tests/all.tcl
+++ b/tests/all.tcl
@@ -8,11 +8,15 @@
# Copyright (c) 2000 by Ajuba Solutions
# All rights reserved.
#
-# RCS: @(#) $Id: all.tcl,v 1.12 2000/10/24 22:30:35 jenn Exp $
+# RCS: @(#) $Id: all.tcl,v 1.13 2001/09/11 17:30:44 andreas_kupries Exp $
set tcltestVersion [package require tcltest]
namespace import -force tcltest::*
+tcltest::singleProcess 1
+tcltest::matchFiles socket.test
+tcltest::verbose {pass start}
+
tcltest::testsDirectory [file dir [info script]]
tcltest::runAllTests
diff --git a/tests/io.test b/tests/io.test
index 3c4d8ed..6c1a710 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: io.test,v 1.20 2001/07/31 19:12:07 vincentdarley Exp $
+# RCS: @(#) $Id: io.test,v 1.21 2001/09/11 17:30:44 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -2653,8 +2653,8 @@ test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMa
incr c
}
}
- set ss [socket -server accept 2828]
- set cs [socket [info hostname] 2828]
+ set ss [socket -server accept 0]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait x
fconfigure $cs -blocking off
writelots $cs $l
@@ -2671,12 +2671,12 @@ test io-29.35 {Tcl_Close vs fileevent vs multiple interpreters} {socket tempNotM
catch {interp delete y}
interp create x
interp create y
- set s [socket -server accept 2828]
+ set s [socket -server accept 0]
proc accept {s a p} {
puts $s hello
close $s
}
- set c [socket [info hostname] 2828]
+ set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
interp share {} $c x
interp share {} $c y
close $c
@@ -6232,27 +6232,27 @@ test io-51.1 {Test old socket deletion on Macintosh} {socket} {
close $s
set wait done
}
- set ss [socket -server accept 2831]
+ set ss [socket -server accept 0]
set wait ""
- set cs [socket [info hostname] 2831]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait wait
lappend result [gets $cs]
close $cs
set wait ""
- set cs [socket [info hostname] 2831]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait wait
lappend result [gets $cs]
close $cs
set wait ""
- set cs [socket [info hostname] 2831]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait wait
lappend result [gets $cs]
close $cs
set wait ""
- set cs [socket [info hostname] 2831]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
vwait wait
lappend result [gets $cs]
close $cs
@@ -6579,9 +6579,9 @@ proc FcopyTestDone {bytes {error {}}} {
}
test io-53.5 {CopyData: error during fcopy} {socket} {
- set listen [socket -server FcopyTestAccept 2828]
+ set listen [socket -server FcopyTestAccept 0]
set in [open $thisScript] ;# 126 K
- set out [socket 127.0.0.1 2828]
+ set out [socket 127.0.0.1 [lindex [fconfigure $listen -sockname] 2]]
catch {unset fcopyTestDone}
close $listen ;# This means the socket open never really succeeds
fcopy $in $out -command FcopyTestDone
@@ -6630,14 +6630,14 @@ test io-54.1 {Recursive channel events} {socket} {
}
incr x
}
- set ss [socket -server accept 2828]
+ set ss [socket -server accept 0]
# We need to delay on some systems until the creation of the
# server socket completes.
set done 0
for {set i 0} {$i < 10} {incr i} {
- if {![catch {set cs [socket [info hostname] 2828]}]} {
+ if {![catch {set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]}]} {
set done 1
break
}
@@ -6665,7 +6665,7 @@ test io-54.1 {Recursive channel events} {socket} {
test io-54.2 {Testing for busy-wait in recursive channel events} {socket} {
set accept {}
set after {}
- set s [socket -server accept 3939]
+ set s [socket -server accept 0]
proc accept {s a p} {
global counter accept
@@ -6693,9 +6693,9 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket} {
set accept {}
}
proc producer {} {
- global writer
+ global writer s
- set writer [socket 127.0.0.1 3939]
+ set writer [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
fconfigure $writer -buffering line
puts -nonewline $writer hello
flush $writer
@@ -6756,8 +6756,8 @@ test io-57.1 {buffered data and file events, gets} {
proc accept {sock args} {
set ::s2 $sock
}
- set server [socket -server accept 4040]
- set s [socket 127.0.0.1 4040]
+ set server [socket -server accept 0]
+ set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
vwait s2
update
fileevent $s2 readable {lappend result readable}
@@ -6777,8 +6777,8 @@ test io-57.2 {buffered data and file events, read} {
proc accept {sock args} {
set ::s2 $sock
}
- set server [socket -server accept 4041]
- set s [socket 127.0.0.1 4041]
+ set server [socket -server accept 0]
+ set s [socket 127.0.0.1 [lindex [fconfigure $server -sockname] 2]]
vwait s2
update
fileevent $s2 readable {lappend result readable}
diff --git a/tests/socket.test b/tests/socket.test
index 2251bb5..dfd6292 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.16 2000/09/21 00:58:30 hobbs Exp $
+# RCS: @(#) $Id: socket.test,v 1.17 2001/09/11 17:30:44 andreas_kupries Exp $
# Running socket tests with a remote server:
# ------------------------------------------
@@ -250,13 +250,14 @@ test socket-2.1 {tcp connection} {socket stdio} {
set f [open script w]
puts $f {
set timer [after 2000 "set x timed_out"]
- set f [socket -server accept 2828]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
set x done
close $file
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
@@ -265,7 +266,8 @@ test socket-2.1 {tcp connection} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
- if {[catch {socket 127.0.0.1 2828} msg]} {
+ gets $f listen
+ if {[catch {socket 127.0.0.1 $listen} msg]} {
set x $msg
} else {
lappend x [gets $f]
@@ -286,7 +288,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} {
set f [open script w]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept 2829]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file] $port"
@@ -294,6 +296,7 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} {
set x done
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
@@ -301,10 +304,11 @@ test socket-2.2 {tcp connection with client port specified} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
+ gets $f listen
global port
- if {[catch {socket -myport $port 127.0.0.1 2829} sock]} {
+ if {[catch {socket -myport $port 127.0.0.1 $listen} sock]} {
set x $sock
- close [socket 127.0.0.1 2829]
+ close [socket 127.0.0.1 $listen]
puts stderr $sock
} else {
puts $sock hello
@@ -351,7 +355,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio}
set f [open script w]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept -myaddr [info hostname] 2831]
+ set f [socket -server accept -myaddr [info hostname] 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
@@ -359,6 +363,7 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio}
set x done
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
@@ -366,7 +371,8 @@ test socket-2.4 {tcp connection with server interface specified} {socket stdio}
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
- if {[catch {socket [info hostname] 2831} sock]} {
+ gets $f listen
+ if {[catch {socket [info hostname] $listen} sock]} {
set x $sock
} else {
puts $sock hello
@@ -382,7 +388,7 @@ test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
set f [open script w]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept 2832]
+ set f [socket -server accept 0]
proc accept {file addr port} {
global x
puts "[gets $file]"
@@ -390,6 +396,7 @@ test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
set x done
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
@@ -397,7 +404,8 @@ test socket-2.5 {tcp connection with redundant server port} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f x
- if {[catch {socket 127.0.0.1 2832} sock]} {
+ gets $f listen
+ if {[catch {socket 127.0.0.1 $listen} sock]} {
set x $sock
} else {
puts $sock hello
@@ -423,7 +431,7 @@ test socket-2.7 {echo server, one line} {socket stdio} {
set f [open script w]
puts $f {
set timer [after 2000 "set x done"]
- set f [socket -server accept 2834]
+ set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -translation lf -buffering line
@@ -439,6 +447,7 @@ test socket-2.7 {echo server, one line} {socket stdio} {
}
}
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
vwait x
after cancel $timer
close $f
@@ -447,7 +456,8 @@ test socket-2.7 {echo server, one line} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
- set s [socket 127.0.0.1 2834]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line -translation lf
puts $s "hello abcdefghijklmnop"
after 1000
@@ -459,7 +469,7 @@ test socket-2.7 {echo server, one line} {socket stdio} {
} {{hello abcdefghijklmnop} done}
test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
makeFile {
- set f [socket -server accept 2835]
+ set f [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
@@ -478,6 +488,7 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
}
set i 0
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
set timer [after 20000 "set x done"]
vwait x
after cancel $timer
@@ -486,7 +497,8 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
} script
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
- set s [socket 127.0.0.1 2835]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
fconfigure $s -buffering line
catch {
for {set x 0} {$x < 50} {incr x} {
@@ -500,25 +512,24 @@ test socket-2.8 {echo server, loop 50 times, single connection} {socket stdio} {
set x
} {done 50}
test socket-2.9 {socket conflict} {socket stdio} {
- set s [socket -server accept 2828]
+ set s [socket -server accept 0]
removeFile script
set f [open script w]
- puts -nonewline $f {socket -server accept 2828}
+ puts -nonewline $f "socket -server accept [lindex [fconfigure $s -sockname] 2]"
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
after 100
- set x [list [catch {close $f} msg] $msg]
+ set x [list [catch {close $f} msg]]
+ regsub "\n.*$" $msg {} msg ; # cut part of the error message containing the port number
+ lappend x $msg
close $s
set x
-} {1 {couldn't open socket: address already in use
- while executing
-"socket -server accept 2828"
- (file "script" line 1)}}
+} {1 {couldn't open socket: address already in use}}
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]
+ set ss [socket -server accept 0]
proc accept {s a p} {
global ss
close $ss
@@ -531,7 +542,7 @@ test socket-2.10 {close on accept, accepted socket lives} {socket} {
close $s
set done 1
}
- set cs [socket [info hostname] 2830]
+ set cs [socket [info hostname] [lindex [fconfigure $ss -sockname] 2]]
puts $cs hello
close $cs
vwait done
@@ -544,9 +555,9 @@ test socket-2.11 {detecting new data} {socket} {
set sock $s
}
- set s [socket -server accept 2400]
+ set s [socket -server accept 0]
set sock ""
- set s2 [socket 127.0.0.1 2400]
+ set s2 [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
vwait sock
puts $s2 one
flush $s2
@@ -571,15 +582,17 @@ test socket-3.1 {socket conflict} {socket stdio} {
removeFile script
set f [open script w]
puts $f {
- set f [socket -server accept 2828]
+ set f [socket -server accept 0]
puts ready
+ puts [lindex [fconfigure $f -sockname] 2]
gets stdin
close $f
}
close $f
set f [open "|[list $::tcltest::tcltest script]" r+]
gets $f
- set x [list [catch {socket -server accept 2828} msg] \
+ gets $f listen
+ set x [list [catch {socket -server accept $listen} msg] \
$msg]
puts $f bye
close $f
@@ -593,7 +606,7 @@ test socket-3.2 {server with several clients} {socket stdio} {
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
set counter 0
- set s [socket -server accept 2828]
+ set s [socket -server accept 0]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
@@ -609,6 +622,7 @@ test socket-3.2 {server with several clients} {socket stdio} {
}
}
puts ready
+ puts [lindex [fconfigure $s -sockname] 2]
vwait x
after cancel $t1
vwait x
@@ -621,11 +635,12 @@ test socket-3.2 {server with several clients} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r+]
set x [gets $f]
- set s1 [socket 127.0.0.1 2828]
+ gets $f listen
+ set s1 [socket 127.0.0.1 $listen]
fconfigure $s1 -buffering line
- set s2 [socket 127.0.0.1 2828]
+ set s2 [socket 127.0.0.1 $listen]
fconfigure $s2 -buffering line
- set s3 [socket 127.0.0.1 2828]
+ set s3 [socket 127.0.0.1 $listen]
fconfigure $s3 -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s1 hello,s1
@@ -647,8 +662,8 @@ test socket-4.1 {server with several clients} {socket stdio} {
removeFile script
set f [open script w]
puts $f {
- gets stdin
- set s [socket 127.0.0.1 2828]
+ set port [gets stdin]
+ set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
for {set i 0} {$i < 100} {incr i} {
puts $s hello
@@ -682,10 +697,11 @@ test socket-4.1 {server with several clients} {socket stdio} {
set t1 [after 30000 "set x timed_out"]
set t2 [after 31000 "set x timed_out"]
set t3 [after 32000 "set x timed_out"]
- set s [socket -server accept 2828]
- puts $p1 open
- puts $p2 open
- puts $p3 open
+ set s [socket -server accept 0]
+ set listen [lindex [fconfigure $s -sockname] 2]
+ puts $p1 $listen
+ puts $p2 $listen
+ puts $p3 $listen
vwait x
vwait x
vwait x
@@ -746,8 +762,8 @@ test socket-6.1 {accept callback error} {socket stdio} {
removeFile script
set f [open script w]
puts $f {
- gets stdin
- socket 127.0.0.1 2848
+ gets stdin port
+ socket 127.0.0.1 $port
}
close $f
set f [open "|[list $::tcltest::tcltest script]" r+]
@@ -756,8 +772,8 @@ test socket-6.1 {accept callback error} {socket stdio} {
set x $args
}
proc accept {s a p} {expr 10 / 0}
- set s [socket -server accept 2848]
- puts $f hello
+ set s [socket -server accept 0]
+ puts $f [lindex [fconfigure $s -sockname] 2]
close $f
set timer [after 10000 "set x timed_out"]
vwait x
@@ -771,12 +787,13 @@ test socket-7.1 {testing socket specific options} {socket stdio} {
removeFile script
set f [open script w]
puts $f {
- socket -server accept 2820
+ set ss [socket -server accept 0]
proc accept args {
global x
set x done
}
puts ready
+ puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
@@ -784,25 +801,27 @@ test socket-7.1 {testing socket specific options} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
- set s [socket 127.0.0.1 2820]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -peername]
close $s
close $f
set l ""
lappend l [string compare [lindex $p 0] 127.0.0.1]
- lappend l [string compare [lindex $p 2] 2820]
+ lappend l [string compare [lindex $p 2] $listen]
lappend l [llength $p]
} {0 0 3}
test socket-7.2 {testing socket specific options} {socket stdio} {
removeFile script
set f [open script w]
puts $f {
- socket -server accept 2821
+ set ss [socket -server accept 2821]
proc accept args {
global x
set x done
}
puts ready
+ puts [lindex [fconfigure $ss -sockname] 2]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
@@ -810,54 +829,57 @@ test socket-7.2 {testing socket specific options} {socket stdio} {
close $f
set f [open "|[list $::tcltest::tcltest script]" r]
gets $f
- set s [socket 127.0.0.1 2821]
+ gets $f listen
+ set s [socket 127.0.0.1 $listen]
set p [fconfigure $s -sockname]
close $s
close $f
set l ""
lappend l [llength $p]
lappend l [lindex $p 0]
- lappend l [expr [lindex $p 2] == 2821]
+ lappend l [expr [lindex $p 2] == $listen]
} {3 127.0.0.1 0}
test socket-7.3 {testing socket specific options} {socket} {
- set s [socket -server accept 2822]
+ set s [socket -server accept 0]
set l [fconfigure $s]
close $s
update
llength $l
} 12
test socket-7.4 {testing socket specific options} {socket} {
- set s [socket -server accept 2823]
+ set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
- set s1 [socket [info hostname] 2823]
+ set listen [lindex [fconfigure $s -sockname] 2]
+ set s1 [socket [info hostname] $listen]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
set l ""
- lappend l [lindex $x 2] [llength $x]
-} {2823 3}
+ lappend l [expr {[lindex $x 2] == $listen}] [llength $x]
+} {1 3}
test socket-7.5 {testing socket specific options} {socket unixOrPc} {
- set s [socket -server accept 2829]
+ set s [socket -server accept 0]
proc accept {s a p} {
global x
set x [fconfigure $s -sockname]
close $s
}
- set s1 [socket 127.0.0.1 2829]
+ set listen [lindex [fconfigure $s -sockname] 2]
+ set s1 [socket 127.0.0.1 $listen]
set timer [after 10000 "set x timed_out"]
vwait x
after cancel $timer
close $s
close $s1
set l ""
- lappend l [lindex $x 0] [lindex $x 2] [llength $x]
-} {127.0.0.1 2829 3}
+ lappend l [lindex $x 0] [expr {[lindex $x 2] == $listen}] [llength $x]
+} {127.0.0.1 1 3}
test socket-8.1 {testing -async flag on sockets} {socket} {
# NOTE: This test may fail on some Solaris 2.4 systems. If it does,
@@ -874,14 +896,14 @@ test socket-8.1 {testing -async flag on sockets} {socket} {
# problem, please email jyl@eng.sun.com. We have not observed this
# failure on Solaris 2.5, so another option (instead of installing
# these patches) is to upgrade to Solaris 2.5.
- set s [socket -server accept 2830]
+ set s [socket -server accept 0]
proc accept {s a p} {
global x
puts $s bye
close $s
set x done
}
- set s1 [socket -async [info hostname] 2830]
+ set s1 [socket -async [info hostname] [lindex [fconfigure $s -sockname] 2]]
vwait x
set z [gets $s1]
close $s
@@ -911,8 +933,8 @@ test socket-9.1 {testing spurious events} {socket} {
fconfigure $s -buffering none -blocking off
fileevent $s readable [list readlittle $s]
}
- set s [socket -server accept 2831]
- set c [socket [info hostname] 2831]
+ set s [socket -server accept 0]
+ set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
puts -nonewline $c 01234567890123456789012345678901234567890123456789
close $c
set timer [after 10000 "set done timed_out"]
@@ -928,7 +950,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
for {set i 0} {$i < 16} {incr i} {
set secondblock "b$secondblock$secondblock"
}
- set l [socket -server accept 2832]
+ set l [socket -server accept 0]
proc accept {s a p} {
fconfigure $s -blocking 0 -translation lf -buffersize 16384 \
-buffering line
@@ -949,7 +971,7 @@ test socket-9.2 {testing async write, fileevents, flush on close} {socket} {
puts -nonewline $s $secondblock
close $s
}
- set s [socket [info hostname] 2832]
+ set s [socket [info hostname] [lindex [fconfigure $l -sockname] 2]]
fconfigure $s -blocking 0 -trans lf -buffering line
set count 0
puts $s hello
@@ -999,8 +1021,8 @@ test socket-9.3 {testing EOF stickyness} {socket} {
fconfigure $s -buffering line -translation lf
fileevent $s writable "write_then_close $s"
}
- set s [socket -server accept 2833]
- set c [socket [info hostname] 2833]
+ set s [socket -server accept 0]
+ set c [socket [info hostname] [lindex [fconfigure $s -sockname] 2]]
fconfigure $c -blocking off -buffering line -translation lf
fileevent $c readable "count_to_eof $c"
set timer [after 1000 timerproc]
@@ -1014,9 +1036,9 @@ 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]
+ set s [socket -server accept 0]
proc accept {s a p} {close $s; error}
- set c [socket 127.0.0.1 2898]
+ set c [socket 127.0.0.1 [lindex [fconfigure $s -sockname] 2]]
vwait goterror
close $s
close $c
@@ -1387,7 +1409,8 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} {
set f [open script2 w]
puts $f [list set tcltest $::tcltest::tcltest]
puts $f {
- set f [socket -server accept 2828]
+ set f [socket -server accept 0]
+ puts [lindex [fconfigure $f -sockname] 2]
proc accept { file addr port } {
close $file
}
@@ -1400,13 +1423,16 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} {
# Launch script2 and wait 5 seconds
- exec $::tcltest::tcltest script2 &
+ ### exec $::tcltest::tcltest script2 &
+ set p [open "|[list $::tcltest::tcltest script2]" r]
+ gets $f 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 {socket 127.0.0.1 2828} msg]} {
+ if {[catch {socket 127.0.0.1 $listen} msg]} {
set x {server socket was not inherited}
} else {
close $msg
@@ -1415,6 +1441,7 @@ test socket-12.1 {testing inheritance of server sockets} {socket exec} {
removeFile script1
removeFile script2
+ close $p
set x
} {server socket was not inherited}
test socket-12.2 {testing inheritance of client sockets} {socket exec} {
@@ -1438,7 +1465,8 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} {
set f [open script2 w]
puts $f [list set tcltest $::tcltest::tcltest]
puts $f {
- set f [socket 127.0.0.1 2829]
+ gets stdin port
+ set f [socket 127.0.0.1 $port]
exec $tcltest script1 &
puts $f testing
flush $f
@@ -1449,7 +1477,7 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} {
# Create the server socket
- set server [socket -server accept 2829]
+ set server [socket -server accept 0]
proc accept { file host port } {
# When the client connects, establish the read handler
global server
@@ -1489,8 +1517,10 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} {
after 5000 [list set failed 1]
# Launch the script2 process
+ ### exec $::tcltest::tcltest script2 &
- exec $::tcltest::tcltest script2 &
+ set p [open "|[list $::tcltest::tcltest script2]" w]
+ puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
vwait x
if {!$failed} {
@@ -1498,6 +1528,7 @@ test socket-12.2 {testing inheritance of client sockets} {socket exec} {
}
removeFile script1
removeFile script2
+ close $p
set x
} {client socket was not inherited}
test socket-12.3 {testing inheritance of accepted sockets} {socket exec} {
@@ -1514,7 +1545,8 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket exec} {
set f [open script2 w]
puts $f [list set tcltest $::tcltest::tcltest]
puts $f {
- set server [socket -server accept 2930]
+ 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}
@@ -1528,12 +1560,14 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket exec} {
# Launch the script2 process and connect to it. See how long
# the socket stays open
- exec $::tcltest::tcltest script2 &
+ ## exec $::tcltest::tcltest script2 &
+ set p [open "|[list $::tcltest::tcltest script2]" r]
+ gets $p listen
after 1000 set ok_to_proceed 1
vwait ok_to_proceed
- set f [socket 127.0.0.1 2930]
+ set f [socket 127.0.0.1 $listen]
fconfigure $f -buffering full -blocking 0
fileevent $f readable [list getdata $f]
@@ -1571,6 +1605,7 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket exec} {
removeFile script1
removeFile script2
+ close $p
set x
} {accepted socket was not inherited}
@@ -1581,7 +1616,8 @@ test socket-13.1 {Testing use of shared socket between two threads} \
threadReap
makeFile {
- set f [socket -server accept 2828]
+ set f [socket -server accept 0]
+ set listen [lindex [fconfigure $f -sockname] 2]
proc accept {s a p} {
fileevent $s readable [list echo $s]
fconfigure $s -buffering line
@@ -1609,9 +1645,11 @@ test socket-13.1 {Testing use of shared socket between two threads} \
# create a thread
set serverthread [testthread create { source script } ]
update
-
+ set port [testthread send $serverthread {set listen}]
+ update
+
after 1000
- set s [socket 127.0.0.1 2828]
+ set s [socket 127.0.0.1 $port]
fconfigure $s -buffering line
catch {