summaryrefslogtreecommitdiffstats
path: root/tests
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2001-07-03 10:26:48 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2001-07-03 10:26:48 (GMT)
commita1b25ad219318a10ce685f69201b2fd94731f74d (patch)
tree69eed001638a824ddb1b2f1704304965fe986533 /tests
parent970995d516c48cff4a1d54a83ea6b8281b28f6ae (diff)
downloadtcl-a1b25ad219318a10ce685f69201b2fd94731f74d.zip
tcl-a1b25ad219318a10ce685f69201b2fd94731f74d.tar.gz
tcl-a1b25ad219318a10ce685f69201b2fd94731f74d.tar.bz2
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.
Diffstat (limited to 'tests')
-rw-r--r--tests/unixInit.test47
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}