diff options
Diffstat (limited to 'tests/unixInit.test')
| -rw-r--r-- | tests/unixInit.test | 47 |
1 files changed, 30 insertions, 17 deletions
diff --git a/tests/unixInit.test b/tests/unixInit.test index 8370d6a..d22c0d7 100644 --- a/tests/unixInit.test +++ b/tests/unixInit.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: unixInit.test,v 1.17 2001/07/02 20:57:02 dgp Exp $ +# RCS: @(#) $Id: unixInit.test,v 1.18 2001/07/03 10:26:48 dkf Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -62,38 +62,51 @@ test unixInit-1.1 {TclpInitPlatform: ignore SIGPIPE} {unixOnly installedTcl} { # This test is really a test of code in tclUnixChan.c, but the # channels are set up as part of initialisation of the interpreter so # the test seems to me to fit here as well as anywhere else. -test unixInit-1.2 {initialisation: channel type deduction} {unixOnly installedTcl} { - set pipe1 [open |[list $::tcltest::tcltest] r+] +test unixInit-1.2 {initialisation: standard channel type deduction} {unixOnly installedTcl} { + # pipe1 is a connection to a server that reports what port it + # starts on, and delivers a constant string to the first client to + # connect to that port before exiting. + set pipe1 [open "|[list $::tcltest::tcltest]" r+] puts $pipe1 { proc accept {channel host port} { - puts $channel { - puts [fconfigure stdin -peername] - flush stdout - exit - } - flush $channel + puts $channel {puts [fconfigure stdin -peername]; exit} close $channel exit } - set server [socket -server accept 0] - puts stdout [fconfigure $server -sockname] - flush stdout - update + puts [fconfigure [socket -server accept 0] -sockname] vwait forever \ } + # Note the backslash above; this is important to make sure that the + # whole string is read before an [exit] can happen... flush $pipe1 set port [lindex [gets $pipe1] 2] set sock [socket localhost $port] - set pipe2 [open |[list $::tcltest::tcltest <@$sock] r] + # pipe2 is a connection to a Tcl interpreter that takes its orders + # from the socket we hand it (i.e. the server we create above.) + # These orders will tell it to print out the details about the + # socket it is taking instructions from, hopefully identifying it + # as a socket. Which is what this test is all about. + set pipe2 [open "|[list $::tcltest::tcltest <@$sock]" r] set result [gets $pipe2] + + # Clear any pending data; stops certain kinds of (non-important) errors + fconfigure $pipe1 -blocking 0; gets $pipe1 + fconfigure $pipe2 -blocking 0; gets $pipe2 + + # Close the pipes and the socket. close $pipe2 close $pipe1 catch {close $sock} - set expected [list 127.0.0.1 localhost $port] - if {[string equal $expected $result]} { + + # Can't use normal comparison, as hostname varies due to some + # installations having a messed up /etc/hosts file. + if { + [string equal 127.0.0.1 [lindex $result 0]] && + [string equal $port [lindex $result 2]] + } then { subst "OK" } else { - subst "Expected: $expected, Got $result" + subst "Expected: `[list 127.0.0.1 localhost $port]', Got `$result'" } } {OK} |