* tclWinSock.c (CreateSocket, TcpAccept): Windows NT creates

sockets so they are inheritable by default.  Turn off this bit so
sockets aren't kept open by exec'ed processes. [Bug: 892]

3 files changed, 234 insertions, 3 deletions

diff --git a/changes b/changes
index fe24854..e903c53 100644
--- a/changes
+++ b/changes
@@ -1,6 +1,6 @@
 Recent user-visible changes to Tcl:
 
-RCS: @(#) $Id: changes,v 1.1.2.12 1998/12/02 20:07:52 welch Exp $
+RCS: @(#) $Id: changes,v 1.1.2.13 1998/12/04 01:19:33 stanton Exp $
 
 1. No more [command1] [command2] construct for grouping multiple
 commands on a single command line.
@@ -3677,6 +3677,11 @@ Vince Darley for this improvement. (JI)
 
 ----------------- Released 8.0.4, 11/20/98 -------------------------
 
+12/3/98 (bug fix) Windows NT creates sockets so they are inheritable
+by default.  Fixed socket code so it turns off this bit right after
+creation so sockets aren't kept open by exec'ed processes. [Bug: 892]
+Thanks to Kevin Kenny for this fix.  (SS)
+
 ======== Changes for 8.0 go above this line ========
 ======== Changes for 8.1 go below this line ========
 
diff --git a/tests/socket.test b/tests/socket.test
index 67e6d46..eef6557 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -59,7 +59,7 @@
 # listening at port 2048. If all fails, a message is printed and the tests
 # using the remote server are not performed.
 #
-# RCS: @(#) $Id: socket.test,v 1.1.2.2 1998/09/24 23:59:36 stanton Exp $
+# RCS: @(#) $Id: socket.test,v 1.1.2.3 1998/12/04 01:19:35 stanton Exp $
 
 if {[string compare test [info procs test]] == 1} then {source defs}
 
@@ -1372,6 +1372,218 @@ test socket-11.13 {testing async write, async flush, async close} {
     set count
 } 65566
 
+test socket-12.1 {testing inheritance of server sockets} {
+    removeFile script1
+    removeFile script2
+
+    # Script1 is just a 10 second delay.  If the server socket
+    # is inherited, it will be held open for 10 seconds
+
+    set f [open script1 w]
+    puts $f {
+	after 10000 exit
+	vwait forever
+    }
+    close $f
+
+    # Script2 creates the server socket, launches script1,
+    # waits a second, and exits.  The server socket will now
+    # be closed unless script1 inherited it.
+
+    set f [open script2 w]
+    puts $f [list set tcltest $tcltest]
+    puts $f {
+	set f [socket -server accept 2828]
+	proc accept { file addr port } {
+	    close $file
+	}
+	exec $tcltest script1 &
+	close $f
+	after 1000 exit
+	vwait forever
+    }
+    close $f
+	
+    # Launch script2 and wait 5 seconds
+
+    exec $tcltest script2 &
+    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 localhost 2828} msg]} {
+	set x {server socket was not inherited}
+    } else {
+	close $msg
+	set x {server socket was inherited}
+    }
+
+    removeFile script1
+    removeFile script2
+    set x
+} {server socket was not inherited}
+test socket-12.2 {testing inheritance of client sockets} {
+    removeFile script1
+    removeFile script2
+
+    # Script1 is just a 10 second delay.  If the server socket
+    # is inherited, it will be held open for 10 seconds
+
+    set f [open script1 w]
+    puts $f {
+	after 10000 exit
+	vwait forever
+    }
+    close $f
+
+    # Script2 opens the client socket and writes to it.  It then
+    # launches script1 and exits.  If the child process inherited the
+    # client socket, the socket will still be open.
+
+    set f [open script2 w]
+    puts $f [list set tcltest $tcltest]
+    puts $f {
+	set f [socket localhost 2829]
+	exec $tcltest script1 &
+	puts $f testing
+	flush $f
+	after 1000 exit
+	vwait forever
+    }
+    close $f
+
+    # Create the server socket
+
+    set server [socket -server accept 2829]
+    proc accept { file host port } {
+
+	# When the client connects, establish the read handler
+	global server
+	close $server
+	fileevent $file readable [list getdata $file]
+	fconfigure $file -buffering line -blocking 0
+	return
+    }
+    proc getdata { file } {
+
+	# Read handler on the accepted socket.
+	global x
+	global failed
+	set status [catch {read $file} data]
+	if {$status != 0} {
+	    set x {read failed, error was $data}
+	    catch { close $file }
+	} elseif {[string compare {} $data]} {
+	} elseif {[fblocked $file]} {
+	} elseif {[eof $file]} {
+	    if {$failed} {
+		set x {client socket was inherited}
+	    } else {
+		set x {client socket was not inherited}
+	    }
+	    catch { close $file }
+	} else {
+	    set x {impossible case}
+	    catch { close $file }
+	}
+	return
+    }
+
+    # If the socket doesn't hit end-of-file in 5 seconds, the
+    # script1 process must have inherited the client.
+
+    set failed 0
+    after 5000 [list set failed 1]
+
+    # Launch the script2 process
+
+    exec $tcltest script2 &
+
+    vwait x
+    if {!$failed} {
+	vwait failed
+    }
+    removeFile script1
+    removeFile script2
+    set x
+} {client socket was not inherited}
+test socket-12.3 {testing inheritance of accepted sockets} {
+    removeFile script1
+    removeFile script2
+
+    set f [open script1 w]
+    puts $f {
+	after 10000 exit
+	vwait forever
+    }
+    close $f
+
+    set f [open script2 w]
+    puts $f [list set tcltest $tcltest]
+    puts $f {
+	set server [socket -server accept 2930]
+	proc accept { file host port } {
+	    global tcltest
+	    puts $file {test data on socket}
+	    exec $tcltest script1 &
+	    after 1000 exit
+	}
+	vwait forever
+    }
+    close $f
+
+    # Launch the script2 process and connect to it.  See how long
+    # the socket stays open
+
+    exec $tcltest script2 &
+
+    after 1000 set ok_to_proceed 1
+    vwait ok_to_proceed
+
+    set f [socket localhost 2930]
+    fconfigure $f -buffering full -blocking 0
+    fileevent $f readable [list getdata $f]
+
+    # If the socket is still open after 5 seconds, the script1 process
+    # must have inherited the accepted socket.
+
+    set failed 0
+    after 5000 set failed 1
+
+    proc getdata { file } {
+
+	# Read handler on the client socket.
+	global x
+	global failed
+	set status [catch {read $file} data]
+	if {$status != 0} {
+	    set x {read failed, error was $data}
+	    catch { close $file }
+	} elseif {[string compare {} $data]} {
+	} elseif {[fblocked $file]} {
+	} elseif {[eof $file]} {
+	    if {$failed} {
+		set x {accepted socket was inherited}
+	    } else {
+		set x {accepted socket was not inherited}
+	    }
+	    catch { close $file }
+	} else {
+	    set x {impossible case}
+	    catch { close $file }
+	}
+	return
+    }
+    
+    vwait x
+
+    removeFile script1
+    removeFile script2
+    set x
+} {accepted socket was not inherited}
+
+
 if {[string match sock* $commandSocket] == 1} {
    puts $commandSocket exit
    flush $commandSocket
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 3b0ba15..1e4b595 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -8,7 +8,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclWinSock.c,v 1.1.2.2 1998/09/24 23:59:53 stanton Exp $
+ * RCS: @(#) $Id: tclWinSock.c,v 1.1.2.3 1998/12/04 01:19:36 stanton Exp $
  */
 
 #include "tclWinInt.h"
@@ -990,6 +990,13 @@ CreateSocket(interp, port, host, server, myaddr, myport, async)
     }
 
     /*
+     * Win-NT has a misfeature that sockets are inherited in child
+     * processes by default.  Turn off the inherit bit.
+     */
+
+    SetHandleInformation( (HANDLE) sock, HANDLE_FLAG_INHERIT, 0 );
+	
+    /*
      * Set kernel space buffering
      */
 
@@ -1485,6 +1492,13 @@ TcpAccept(infoPtr)
     }
 
     /*
+     * Win-NT has a misfeature that sockets are inherited in child
+     * processes by default.  Turn off the inherit bit.
+     */
+
+    SetHandleInformation( (HANDLE) newSocket, HANDLE_FLAG_INHERIT, 0 );
+	
+    /*
      * Add this socket to the global list of sockets.
      */