Fix for Bug #438070 I believe; for various reasons, testing on the

environment where the actual bug was reported is very difficult (I've
no access to an Alpha box, and even going to a ix86-redhat-linux is
very difficult due to the way my sources are set up.)  Improved the
comments in the test too.

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}