small amend (code review, implicit gets for *nix/eof to avoid endless event-cycle, etc)

socket.test: optimized 'hot spot' socket-12.2 test-case (10s -> 10ms).

tests/io.test

@@ -1058,19 +1058,19 @@ test io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} {stdio o
     puts -nonewline $f "foobar"
     fconfigure $f -blocking 0
     variable x {}
-    after 500 [namespace code { lappend x timeout }]
-    fileevent $f readable [namespace code { lappend x [gets $f] }]
-    vwait [namespace which -variable x]
+    fileevent $f readable [namespace code { lappend x [gets $f] ready }]
+    set tmr [after 1000 [namespace code { lappend x timeout }]]
     vwait [namespace which -variable x]
+    after cancel $tmr
     fconfigure $f -blocking 1
     puts -nonewline $f "baz\n"
-    after 500 [namespace code { lappend x timeout }]
     fconfigure $f -blocking 0
+    set tmr [after 1000 [namespace code { lappend x timeout }]]
     vwait [namespace which -variable x]
-    vwait [namespace which -variable x]
+    after cancel $tmr
     close $f
     set x
-} {{} timeout foobarbaz timeout}
+} {{} ready foobarbaz ready}
 
 test io-7.1 {FilterInputBytes: split up character at end of buffer} {
     # (result == TCL_CONVERT_MULTIBYTE)
@@ -1388,9 +1388,9 @@ test io-12.3 {ReadChars: allocate more space} {
     close $f
     set x
 } {abcdefghijklmnopqrstuvwxyz}
-test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
+proc _test_split_up_char {time} {
     # (srcRead == 0)
-
+    variable path
     set f [open "|[list [interpreter] $path(cat)]" w+]
     fconfigure $f -encoding binary -buffering none -buffersize 16
     puts -nonewline $f "123456789012345\x96"
@@ -1407,11 +1407,17 @@ test io-12.4 {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
     vwait [namespace which -variable x]
     fconfigure $f -encoding binary -blocking 1
     puts -nonewline $f "\x7b"
-    after 500			;# Give the cat process time to catch up
+    after $time			;# Give the cat process time to catch up
     fconfigure $f -encoding shiftjis -blocking 0
     vwait [namespace which -variable x]
     close $f
     set x
+}
+test io-12.4a {ReadChars: split-up char} {stdio testchannel openpipe fileevent} {
+    _test_split_up_char 100
+} [list "123456789012345" 1 "\u672c" 0]
+test io-12.4b {ReadChars: split-up char} {stdio testchannel openpipe fileevent slowTest} {
+    _test_split_up_char 5000
 } [list "123456789012345" 1 "\u672c" 0]
 test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe fileevent} {
     set path(test1) [makeFile {
@@ -1432,12 +1438,12 @@ test io-12.5 {ReadChars: fileevents on partial characters} {stdio openpipe filee
     fconfigure $f -blocking 0 -encoding utf-8
     variable x {}
     vwait [namespace which -variable x]
-    after 500 [namespace code { lappend x timeout }]
+    after 50 [namespace code { lappend x timeout }]
     vwait [namespace which -variable x]
     puts $f "go2"
     flush $f
     vwait [namespace which -variable x]
-    after 500 [namespace code { lappend x timeout }]
+    after 50 [namespace code { lappend x timeout }]
     vwait [namespace which -variable x]
     puts $f "go3"
     flush $f
@@ -1610,25 +1616,28 @@ test io-13.5 {TranslateInputEOL: crlf mode: naked lf} {
 test io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} {stdio testchannel openpipe fileevent} {
     # (chanPtr->flags & INPUT_SAW_CR)
     # This test may fail on slower machines.
-
     set f [open "|[list [interpreter] $path(cat)]" w+]
     fconfigure $f -blocking 0 -buffering none -translation {auto lf}
 
     fileevent $f read [namespace code "ready $f"]
     proc ready {f} {
 	variable x
+	variable y
 	lappend x [read $f] [testchannel queuedcr $f]
+	set y ok
     }
     variable x {}
     variable y {}
 
     puts -nonewline $f "abcdefghj\r"
-    after 500 [namespace code {set y ok}]
+    set tmr [after 500 [namespace code {set y ok}]]
     vwait [namespace which -variable y]
+    after cancel $tmr
 
     puts -nonewline $f "\n01234"
-    after 500 [namespace code {set y ok}]
+    set tmr [after 500 [namespace code {set y ok}]]
     vwait [namespace which -variable y]
+    after cancel $tmr
 
     close $f
     set x
@@ -1910,9 +1919,12 @@ test io-14.9 {reuse of stdio special channels} {stdio openpipe fileevent} {
     # Added delay to give Windows time to stop the spawned process and clean
     # up its grip on the file test1. Added delete as proper test cleanup.
     # The failing tests were 18.1 and 18.2 as first re-users of file "test1".
-    after 10000
-    file delete $path(script)
-    file delete $path(test1)
+    while {[catch {
+	file delete $path(script)
+	file delete $path(test1)
+    }]} {
+	after 50
+    }
     set c
 } hello
 
@@ -2224,7 +2236,7 @@ test io-27.5 {FlushChannel, implicit flush when buffer fills and on close} \
 set path(pipe)   [makeFile {} pipe]
 set path(output) [makeFile {} output]
 test io-27.6 {FlushChannel, async flushing, async close} \
-	{stdio asyncPipeClose openpipe} {
+-constraints {stdio asyncPipeClose openpipe} -setup {
     # This test may fail on old Unix systems (seen on IRIX64 6.5) with
     # obsolete gettimeofday() calls.  See Tcl Bugs 3530533, 1942197.
     file delete $path(pipe)
@@ -2234,12 +2246,13 @@ test io-27.6 {FlushChannel, async flushing, async close} \
     puts $f {
 	fconfigure $f -translation lf -buffering none -eofchar {}
 	while {![eof stdin]} {
-	    after 20
-	    puts -nonewline $f [read stdin 1024]
+	    after 5
+	    puts -nonewline $f [read stdin 4096]
 	}
 	close $f
     }
     close $f
+} -body {
     set x 01234567890123456789012345678901
     for {set i 0} {$i < 11} {incr i} {
         set x "$x$x"
@@ -2252,7 +2265,7 @@ test io-27.6 {FlushChannel, async flushing, async close} \
     close $f
     set counter 0
     while {([file size $path(output)] < 65536) && ($counter < 1000)} {
-	after 20 [list incr [namespace which -variable counter]]
+	after 1 [list incr [namespace which -variable counter]]
 	vwait [namespace which -variable counter]
     }
     if {$counter == 1000} {
@@ -2260,7 +2273,17 @@ test io-27.6 {FlushChannel, async flushing, async close} \
     } else {
         set result ok
     }
-} ok
+} -result ok -cleanup {
+    # allow a little time for the background process to close.
+    # otherwise, the following test fails on the [file delete $path(output)
+    # on Windows because a process still has the file open.
+    while {[catch {
+	file delete $path(pipe)
+	file delete $path(output)
+    }]} {
+	after 50
+    }
+}
 
 # Tests closing a channel. The functions tested are CloseChannel and Tcl_Close.
 
@@ -2785,7 +2808,8 @@ test io-29.30 {Tcl_WriteChars, crlf mode} {
     close $f
     file size $path(test1)
 } 25
-test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
+test io-29.31 {Tcl_WriteChars, background flush} \
+-constraints {stdio openpipe} -setup {
     # This test may fail on old Unix systems (seen on IRIX64 6.5) with
     # obsolete gettimeofday() calls.  See Tcl Bugs 3530533, 1942197.
     file delete $path(pipe)
@@ -2801,10 +2825,12 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
     puts $f "}"
     puts $f {close $f}
     close $f
+} -body {
     set x 01234567890123456789012345678901
     for {set i 0} {$i < 11} {incr i} {
 	set x "$x$x"
     }
+    # length of x is 65536
     set f [open $path(output) w]
     close $f
     set f [open "|[list [interpreter] $path(pipe)]" r+]
@@ -2821,14 +2847,20 @@ test io-29.31 {Tcl_WriteChars, background flush} {stdio openpipe} {
     } else {
 	set result ok
     }
+    set result
+} -result ok -cleanup {
     # allow a little time for the background process to close.
     # otherwise, the following test fails on the [file delete $path(output)
     # on Windows because a process still has the file open.
-    after 100 set v 1; vwait v
-    set result
-} ok
+    while {[catch {
+	file delete $path(pipe)
+	file delete $path(output)
+    }]} {
+	after 50
+    }
+}
 test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
-	{stdio asyncPipeClose openpipe} {
+-constraints {stdio asyncPipeClose openpipe} -setup {
     # This test may fail on old Unix systems (seen on IRIX64 6.5) with
     # obsolete gettimeofday() calls.  See Tcl Bugs 3530533, 1942197.
     file delete $path(pipe)
@@ -2839,16 +2871,18 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
     set x [list while {![eof stdin]}]
     set x "$x \{"
     puts $f $x
-    puts $f {  after 20}
-    puts $f {  puts -nonewline $f [read stdin 1024]}
+    puts $f {  after 5}
+    puts $f {  puts -nonewline $f [read stdin 4096]}
     puts $f {  flush $f}
     puts $f "\}"
     puts $f {close $f}
     close $f
+} -body {
     set x 01234567890123456789012345678901
     for {set i 0} {$i < 11} {incr i} {
 	set x "$x$x"
     }
+    # length of x is 65536
     set f [open $path(output) w]
     close $f
     set f [open "|[list [interpreter] $path(pipe)]" r+]
@@ -2857,7 +2891,7 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
     close $f
     set counter 0
     while {([file size $path(output)] < 65536) && ($counter < 1000)} {
-	after 20 [list incr [namespace which -variable counter]]
+	after 1 [list incr [namespace which -variable counter]]
 	vwait [namespace which -variable counter]
     }
     if {$counter == 1000} {
@@ -2865,7 +2899,17 @@ test io-29.32 {Tcl_WriteChars, background flush to slow reader} \
     } else {
 	set result ok
     }
-} ok
+} -result ok -cleanup {
+    # allow a little time for the background process to close.
+    # otherwise, the following test fails on the [file delete $path(output)
+    # on Windows because a process still has the file open.
+    while {[catch {
+	file delete $path(pipe)
+	file delete $path(output)
+    }]} {
+	after 50
+    }
+}
 test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
     set f [open $path(script) w]
     puts $f "set f \[[list open $path(test1) w]]"
@@ -4700,9 +4744,44 @@ test io-34.20 {Tcl_Tell combined with writing} {
     close $f
     set l
 } {29 39 40 447}
-test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
-    file delete $path(test3)
-    set f [open $path(test3) w]
+proc _test_seek_tell {fn offset} {
+    if {$fn eq ""} {
+    	# test using virtual (reflected) channel:
+	proc driver {cmd args} {
+	    variable index
+	    set chan [lindex $args 0]
+	    switch -- $cmd {
+		initialize {
+		    set index($chan) 0
+		    return {initialize finalize watch write seek}
+		}
+		finalize {
+		    unset index($chan)
+		    return
+		}
+		watch {}
+		write {
+		    set s [string length [lindex $args 1]]
+		    incr index($chan) $s
+		    return $s
+		}
+		seek {
+		    switch -- [lindex $args 2] \
+		    current {
+			return [incr index($chan) [lindex $args 1]]
+		    } start {
+			return [set index($chan) [lindex $args 1]]
+		    }
+		    return -code error EINVARG
+		}
+	    }
+	}
+	set f [chan create write [namespace which driver]]
+    } else {
+	# test using file:
+	file delete $fn
+	set f [open $fn w]
+    }
     fconfigure $f -encoding binary
     set l ""
     lappend l [tell $f]
@@ -4710,17 +4789,34 @@ test io-34.21 {Tcl_Seek and Tcl_Tell on large files} {largefileSupport} {
     lappend l [tell $f]
     flush $f
     lappend l [tell $f]
-    # 4GB offset!
-    seek $f 0x100000000
+    # jump to offset
+    seek $f $offset
     lappend l [tell $f]
     puts -nonewline $f abcdef
     lappend l [tell $f]
     close $f
-    lappend l [file size $path(test3)]
-    # truncate...
-    close [open $path(test3) w]
-    lappend l [file size $path(test3)]
+    if {$fn ne ""} {
+	lappend l [file size $fn]
+	# truncate...
+	close [open $fn w]
+	lappend l [file size $fn]
+	file delete $fn
+    } else {
+	lappend l - -
+    }
     set l
+}
+test io-34.21a {Tcl_Seek outside and Tcl_Tell} {} {
+    _test_seek_tell $path(test3) 4096
+} {0 6 6 4096 4102 4102 0}
+test io-34.21b {Tcl_Seek and Tcl_Tell on large files} {
+    # Note: this test-case is fast because it does nothing in virtual testfilesystem
+    _test_seek_tell "" 0x100000000
+} {0 6 6 4294967296 4294967302 - -}
+test io-34.21c {Tcl_Seek and Tcl_Tell on large files} {largefileSupport slowTest} {
+    # Note: this test-case may be very slow (write 4GB by seek), so provided via constraint slowTest
+    # 4GB offset!
+    _test_seek_tell $path(test3) 0x100000000
 } {0 6 6 4294967296 4294967302 4294967302 0}
 
 # Test Tcl_Eof
@@ -5084,8 +5180,11 @@ test io-36.1 {Tcl_InputBlocked on nonblocking pipe} {stdio openpipe} {
     lappend x [gets $f1]
     lappend x [fblocked $f1]
     flush $f1
-    after 200
-    lappend x [gets $f1]
+    set i 100
+    while {[set v [gets $f1]] eq "" && [incr i -1]} {
+	after 10
+    }
+    lappend x $v
     lappend x [fblocked $f1]
     lappend x [gets $f1]
     lappend x [fblocked $f1]
@@ -5107,8 +5206,11 @@ test io-36.1.1 {Tcl_InputBlocked on nonblocking binary pipe} {stdio openpipe} {
     lappend x [gets $f1]
     lappend x [fblocked $f1]
     flush $f1
-    after 200
-    lappend x [gets $f1]
+    set i 100
+    while {[set v [gets $f1]] eq "" && [incr i -1]} {
+	after 10
+    }
+    lappend x $v
     lappend x [fblocked $f1]
     lappend x [gets $f1]
     lappend x [fblocked $f1]
@@ -5479,15 +5581,15 @@ test io-39.17 {Tcl_SetChannelOption: -encoding, clearing CHANNEL_NEED_MORE_DATA}
     variable x {}
     fileevent $f readable [namespace code { lappend x [read $f] }]
     vwait [namespace which -variable x]
-    after 300 [namespace code { lappend x timeout }]
+    after 30 [namespace code { lappend x timeout }]
     vwait [namespace which -variable x]
     fconfigure $f -encoding utf-8
     vwait [namespace which -variable x]
-    after 300 [namespace code { lappend x timeout }]
+    after 30 [namespace code { lappend x timeout }]
     vwait [namespace which -variable x]
     fconfigure $f -encoding binary
     vwait [namespace which -variable x]
-    after 300 [namespace code { lappend x timeout }]
+    after 30 [namespace code { lappend x timeout }]
     vwait [namespace which -variable x]
     close $f
     set x
@@ -7324,8 +7426,8 @@ test io-53.3 {CopyData: background read underflow} {stdio unix openpipe fcopy} {
 	fcopy stdin stdout -command { set x }
 	vwait x
 	set f [}
-    puts $f1 [list open $path(test1) w]]
-    puts $f1 {
+	puts $f1 [list open $path(test1) w]]
+	puts $f1 {
 	fconfigure $f -translation lf
 	puts $f "done"
 	close $f
@@ -7472,7 +7574,7 @@ proc doFcopy {in out {bytes 0} {error {}}} {
 	set fcopyTestDone 0
     } else {
         # Delay next fcopy to wait for size>0 input bytes
-        after 100 [list fcopy $in $out -size 1000 \
+        after 1 [list fcopy $in $out -size 1000 \
 		-command [namespace code [list doFcopy $in $out]]]
     }
 }
@@ -7485,16 +7587,16 @@ test io-53.7 {CopyData: Flooding fcopy from pipe} {stdio openpipe fcopy} {
     puts $f1 {
 	# Write  10 bytes / 10 msec
 	proc Write {count} {
-	    puts -nonewline "1234567890"
-	    if {[incr count -1]} {
-	        after 10 [list Write $count]
-	    } else {
-	        set ::ready 1
+	    while {$count} {
+		puts -nonewline "1234567890"
+		if {($count % 10) == 0} {
+		    after 1
+		}
+		incr count -1
 	    }
 	}
 	fconfigure stdout -buffering none
-	Write 345 ;# 3450 bytes ~3.45 sec
-	vwait ready
+	Write 345 ;# 3450 bytes ~ upto 0.05sec
 	exit 0
     }
     close $f1
@@ -7642,11 +7744,11 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
     puts $pipe {
 	fconfigure stdout -translation binary -buffering line
 	puts stderr Waiting...
-	after 1000
+	after 50
 	foreach x {a b c} {
 	    puts stderr Looping...
 	    puts $x
-	    after 500
+	    after 10
 	}
 	proc bye args {
 	    if {[gets stdin line]<0} {
@@ -7665,22 +7767,27 @@ test io-53.9 {CopyData: -size and event interaction, Bug 780533} -setup {
 	return
     }
     set ::forever {}
-    set out [open $out w]
+    set outf [open $out w]
 } -constraints {stdio openpipe fcopy} -body {
-    fcopy $pipe $out -size 6 -command ::done
+    fcopy $pipe $outf -size 6 -command ::done
     set token [after 5000 {
 	set ::forever {fcopy hangs}
     }]
     vwait ::forever
-    catch {after cancel $token}
     set ::forever
 } -cleanup {
     close $pipe
+    catch {close $outf}
     rename ::done {}
-    after 1000;			# Give Windows time to kill the process
-    catch {close $out}
+    while {$::forever ne {fcopy hangs} && [catch {
+	file delete $err
+	file delete $out
+    }]} {
+	after 50;		# Give Windows time to kill the process
+    }
     catch {removeFile out}
     catch {removeFile err}
+    catch {after cancel $token}
     catch {unset ::forever}
 } -result OK
 test io-53.10 {Bug 1350564, multi-directional fcopy} -setup {
@@ -7946,9 +8053,12 @@ test io-54.1 {Recursive channel events} {socket fileevent} {
     close $cs
     list $result $x
 } {{{line 1} 1 2} 2}
-test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileevent} {
-    set accept {}
-    set after {}
+proc _test_busy_wait {time} {
+    variable writer
+    variable accept {}
+    variable counter
+    variable aftertime $time
+    variable after {}
     variable s [socket -server [namespace code accept] -myaddr 127.0.0.1 0]
     proc accept {s a p} {
 	variable counter
@@ -7960,6 +8070,7 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve
 	fileevent $s readable [namespace code "doit $s"]
     }
     proc doit {s} {
+    	variable aftertime
 	variable counter
 	variable after
 
@@ -7967,10 +8078,11 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve
 	set l [gets $s]
 	if {"$l" == ""} {
 	    fileevent $s readable [namespace code "doit1 $s"]
-	    set after [after 1000 [namespace code newline]]
+	    set after [after $aftertime [namespace code newline]]
 	}
     }
     proc doit1 {s} {
+    	# this will be normally never executed:
 	variable counter
 	variable accept
 
@@ -8003,7 +8115,13 @@ test io-54.2 {Testing for busy-wait in recursive channel events} {socket fileeve
     close $s
     after cancel $after
     if {$accept != {}} {close $accept}
-    set counter
+    return $counter
+}
+test io-54.2a {Testing for busy-wait in recursive channel events} {socket fileevent} {
+    _test_busy_wait 100
+} 1
+test io-54.2b {Testing for busy-wait in recursive channel events} {socket fileevent slowTest} {
+    _test_busy_wait 5000
 } 1
 
 set path(fooBar) [makeFile {} fooBar]
@@ -8068,15 +8186,15 @@ test io-57.1 {buffered data and file events, gets} {fileevent} {
     puts $s "12\n34567890"
     flush $s
     variable result [gets $s2]
-    after 1000 [namespace code {lappend result timer}]
+    set tmr [after 1000 [namespace code {lappend result timeout}]]
     vwait [namespace which -variable result]
     lappend result [gets $s2]
-    vwait [namespace which -variable result]
+    after cancel $tmr
     close $s
     close $s2
     close $server
     set result
-} {12 readable 34567890 timer}
+} {12 readable 34567890}
 test io-57.2 {buffered data and file events, read} {fileevent} {
     proc accept {sock args} {
 	variable s2
@@ -8091,15 +8209,15 @@ test io-57.2 {buffered data and file events, read} {fileevent} {
     puts -nonewline $s "1234567890"
     flush $s
     variable result [read $s2 1]
-    after 1000 [namespace code {lappend result timer}]
+    set tmr [after 1000 [namespace code {lappend result timeout}]]
     vwait [namespace which -variable result]
     lappend result [read $s2 9]
-    vwait [namespace which -variable result]
+    after cancel $tmr
     close $s
     close $s2
     close $server
     set result
-} {1 readable 234567890 timer}
+} {1 readable 234567890}
 
 test io-58.1 {Tcl_NotifyChannel and error when closing} {stdio unixOrPc openpipe fileevent} {
     set out [open $path(script) w]

tests/socket.test

@@ -1539,12 +1539,12 @@ test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
     file delete $path(script1)
     file delete $path(script2)
 
-    # Script1 is just a 20 second delay.  If the server socket
+    # Script1 is just a 5 second delay.  If the server socket
     # is inherited, it will be held open for 10 seconds
 
     set f [open $path(script1) w]
     puts $f {
-	after 20000 exit
+	after 5000 exit
 	vwait forever
     }
     close $f
@@ -1555,16 +1555,17 @@ test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
 
     set f [open $path(script2) w]
     puts $f [list set tcltest [interpreter]]
+    puts $f [list set script1 $path(script1)]
     puts -nonewline $f {
-        gets stdin port
-	set f [socket 127.0.0.1 $port]
-        exec $tcltest }
-    puts $f [list $path(script1) &]
-    puts $f {
-	puts $f testing
-	flush $f
-	after 1000 exit
-	vwait forever
+	set port [lindex $::argv 0]
+	puts "testing from [pid]: for port $port"
+	set sock [socket 127.0.0.1 $port]
+	if {$::tcl_platform(platform) eq "windows"} {set redir NUL:} else {set redir /dev/null}
+	set pid1 [exec $tcltest $script1 >& $redir &]
+	puts $sock [list "started" $pid1]
+	flush $sock
+	puts "testing end"
+	exit
     }
     close $f
 
@@ -1576,50 +1577,98 @@ test socket-12.2 {testing inheritance of client sockets} {socket stdio exec} {
 	global server
 	close $server
 	fileevent $file readable [list getdata $file]
-	fconfigure $file -buffering line -blocking 0
+	fconfigure $file -buffering none -blocking 0
 	return
     }
     proc getdata { file } {
 	# Read handler on the accepted socket.
 	global x
-	global failed
+	global done
+	set data {}
 	set status [catch {read $file} data]
 	if {$status != 0} {
 	    set x {read failed, error was $data}
+	    set done -2
 	    catch { close $file }
-	} elseif {[string compare {} $data]} {
+	} elseif {$data ne ""} {
+	    if {[lindex $data 0] eq "started"} {
+		variable pid1 [lindex $data 1]
+	    }
 	} elseif {[fblocked $file]} {
 	} elseif {[eof $file]} {
-	    if {$failed} {
-		set x {client socket was inherited}
+	    fileevent $file readable {}
+	    if {$done} {
+		if {$done <= -1} {
+		    if {$x eq "none"} {set x timeout}
+		} else {
+		    set x {client socket was inherited}
+		}
 	    } else {
 		set x {client socket was not inherited}
 	    }
+	    # touch to signal end:
+	    after 0 [namespace code {set done $done}]
 	    catch { close $file }
 	} else {
 	    set x {impossible case}
 	    catch { close $file }
+	    set done -2
 	}
 	return
     }
-
-    # If the socket doesn't hit end-of-file in 10 seconds, the
-    # script1 process must have inherited the client.
-
-    set failed 0
-    after 10000 [list set failed 1]
-
-    # Launch the script2 process
-    ### exec [interpreter] script2 &
-
-    set p [open "|[list [interpreter] $path(script2)]" w]
-    puts $p [lindex [fconfigure $server -sockname] 2] ; flush $p
-
-    vwait x
-    if {!$failed} {
-	vwait failed
+    proc scriptend {p} {
+	# wait for end of p:
+	variable pid2
+	variable done
+	variable waitcntr
+	set time 100
+	gets $p
+	if {![eof $p]} {
+	    if {[info command ::testisprocessrunning] eq ""
+	     || [testisprocessrunning $pid2]
+	    } {
+		# avoid endless event-cycle if process "hangs" before eof signaled:
+		if {[incr waitcntr] > 1000} {
+		    fileevent $p readable {}
+		}
+		return
+	    }
+	    set time 0; # process exited - notify immediately
+	}
+	fileevent $p readable {}
+	# Pipe closed - process exited, give few time (0.1s) to fulfill the end.
+	after $time [namespace code {set done 1}]
+	# If the socket doesn't hit end-of-file in 0.1 seconds, the
+	# script1 process must have inherited the client.
+	close $p
     }
-    close $p
+
+    set done 0
+
+    # Launch the script2 process with port as argument
+    set port [lindex [fconfigure $server -sockname] 2]
+    set pid1 {}
+    set p [open "|[list [interpreter] $path(script2) $port]" w+]
+    set pid2 [pid $p]
+    fconfigure $p -buffering none -blocking 0
+    set waitcntr 0
+    fileevent $p readable [list scriptend $p]
+
+    set x none
+    set tmr [after 2000 [namespace code {set done -1; set x timeout}]]
+    vwait done
+    if {[info command ::testisprocessrunning] ne ""} {
+	# be sure process 2 is exited:
+	while {$done == 0 && [testisprocessrunning $pid2]} {
+	    after 10; update
+	}
+	# and process 1 is still running:
+	if {$done >= 0 && $pid1 ne "" && ![testisprocessrunning $pid1]} {
+	    set x {unexpected, process 2 exited}
+	}
+    }
+    after cancel $tmr
+    catch {close $p}
     set x
 } {client socket was not inherited}
 test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
@@ -1628,7 +1677,7 @@ test socket-12.3 {testing inheritance of accepted sockets} {socket stdio exec} {
 
     set f [open $path(script1) w]
     puts $f {
-	after 10000 exit
+	after 1000 exit
 	vwait forever
     }
     close $f

unix/tclUnixTest.c

@@ -82,6 +82,8 @@ static int		TestgotsigCmd(ClientData dummy,
 static void		AlarmHandler(int signum);
 static int		TestchmodCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, CONST char **argv);
+static int		TestIsProcessRunningCmd(ClientData dummy,
+			    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 
 /*
  *----------------------------------------------------------------------
@@ -124,6 +126,8 @@ TclplatformtestInit(
             (ClientData) 0, NULL);
     Tcl_CreateCommand(interp, "testgotsig", TestgotsigCmd,
             (ClientData) 0, NULL);
+    Tcl_CreateObjCommand(interp, "testisprocessrunning", TestIsProcessRunningCmd,
+	    NULL, NULL);
     return TCL_OK;
 }
 
@@ -783,3 +787,42 @@ TestchmodCmd(
     }
     return TCL_OK;
 }
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TestIsProcessRunningCmd --
+ *
+ *	Implements the "testisprocessrunning" cmd.  Used for testing whether
+ *	the process with given pid is running (exists).
+ *
+ * Results:
+ *	A standard Tcl boolean result (1 - if process exists, 0 - otherwise).
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+TestIsProcessRunningCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Parameter count */
+    Tcl_Obj *const * objv)	/* Parameter vector */
+{
+    Tcl_WideInt pid;
+    int ret;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "pid");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetWideIntFromObj(interp, objv[1], &pid) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    /* first reap detached processes (to avoid hangs on half-closed handles) */
+    Tcl_ReapDetachedProcs();
+    /* now check via OS mechanisms it is really exited */
+    ret = kill((pid_t)pid, 0);
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(ret == 0 ? 1 : 0));
+    return TCL_OK;
+}

win/tclWinTest.c

@@ -43,6 +43,8 @@ static Tcl_ObjCmdProc	TestExceptionCmd;
 static int		TestplatformChmod(const char *nativePath, int pmode);
 static int		TestchmodCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
+static int		TestIsProcessRunningCmd(ClientData dummy,
+			    Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 
 /*
  *----------------------------------------------------------------------
@@ -76,6 +78,8 @@ TclplatformtestInit(
     Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testwinsleep", TestwinsleepCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testisprocessrunning", TestIsProcessRunningCmd,
+	    NULL, NULL);
     return TCL_OK;
 }
 
@@ -761,6 +765,51 @@ TestchmodCmd(
     return TCL_OK;
 }
 
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TestIsProcessRunningCmd --
+ *
+ *	Implements the "testisprocessrunning" cmd.  Used for testing whether
+ *	the process with given pid is running (exists).
+ *
+ * Results:
+ *	A standard Tcl boolean result (1 - if process exists, 0 - otherwise).
+ *
+ *---------------------------------------------------------------------------
+ */
+
+static int
+TestIsProcessRunningCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Parameter count */
+    Tcl_Obj *const * objv)	/* Parameter vector */
+{
+    int pid;
+    HANDLE process;
+    DWORD ret = 0;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "pid");
+	return TCL_ERROR;
+    }
+    if (Tcl_GetIntFromObj(interp, objv[1], &pid) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    /* first reap detached processes (to avoid hangs on half-closed handles) */
+    Tcl_ReapDetachedProcs();
+    /* now check via OS mechanisms it is really exited */
+    process = OpenProcess(SYNCHRONIZE, FALSE, (DWORD)pid);
+    if (process == INVALID_HANDLE_VALUE) {
+	goto end;
+    }
+    ret = WaitForSingleObject(process, 0);
+    CloseHandle(process);
+end:
+    Tcl_SetObjResult(interp, Tcl_NewIntObj(ret == WAIT_TIMEOUT ? 1 : 0));
+    return TCL_OK;
+}
 /*
  * Local Variables:
  * mode: c