>From 6691df7b11bbd79c1e5fbdc201b97327bcf6cb53 Mon Sep 17 00:00:00 2001
From: Peter Bex <address@hidden>
Date: Fri, 22 Nov 2013 20:34:30 +0100
Subject: [PATCH] Fix "process" under Windows and fix general error handling
 under Windows.

- In PROCESS, don't try to mark duplicated descriptors from the parent
    process as inheritable; this isn't allowed (and they should already
    be inheritable or you can't duplicate them, and we duplicate with
    SAME_ACCESS anyway).
- In PROCESS[*], don't try to close handles that haven't been opened.
- When setting the errno for nonexisting error, don't loop endlessly.
- When no error is known, just set it to ENOTSUP (what to do?)
- Add simple regression test for process/process*.
---
 NEWS                  |    4 +++-
 posixwin.scm          |   27 ++++++++++++++++-----------
 tests/posix-tests.scm |   11 +++++++++++
 3 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/NEWS b/NEWS
index 2f1e06d..a168975 100644
--- a/NEWS
+++ b/NEWS
@@ -13,7 +13,9 @@
      use modules and forgot to require ports but use procedures from it.
   - Support has been added for the space-safe R7RS macro "delay-force".
   - Export file-type from the posix unit (thanks to Alan Post).
-  - unsetenv has been fixed on Windows
+  - unsetenv has been fixed on Windows.
+  - The process procedure has been fixed on Windows.
+  - The posix unit will no longer hang upon any error in Windows.
 
 - Platform support
   - CHICKEN can now be built on AIX (contributed by Erik Falor)
diff --git a/posixwin.scm b/posixwin.scm
index c5091a5..09f69e3 100644
--- a/posixwin.scm
+++ b/posixwin.scm
@@ -369,15 +369,16 @@ static errmap_t errmap[] =
 static void C_fcall
 set_errno(DWORD w32err)
 {
-    errmap_t *map = errmap;
-    for (; errmap->win32; ++map)
+    errmap_t *map;
+    for (map = errmap; map->win32; ++map)
     {
-	if (errmap->win32 == w32err)
+	if (map->win32 == w32err)
 	{
-	    errno = errmap->libc;
+	    errno = map->libc;
 	    return;
 	}
     }
+    errno = ENOSYS; /* For lack of anything better */
 }
 
 static int C_fcall
@@ -785,15 +786,13 @@ C_process(const char * app, const char * cmdlin, const char ** env,
 		if (modes[i]=='r') { child_io_handles[i]=a; parent_end=b; }
 		else		   { parent_end=a; child_io_handles[i]=b; }
 		success = (io_fds[i] = _open_osfhandle((C_word)parent_end,0)) >= 0;
+                /* Make new handle inheritable */
+		if (success)
+		  success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
 	    }
 	}
     }
 
-    /****** make handles inheritable */
-
-    for (i=0; i<3 && success; ++i)
-	success = SetHandleInformation(child_io_handles[i], HANDLE_FLAG_INHERIT, -1);
-
 #if 0 /* Requires a sorted list by key! */
     /****** create environment block if necessary ****/
 
@@ -853,7 +852,10 @@ C_process(const char * app, const char * cmdlin, const char ** env,
     /****** cleanup & return *********/
 
     /* parent must close child end */
-    for (i=0; i<3; ++i) CloseHandle(child_io_handles[i]);
+    for (i=0; i<3; ++i) {
+	if (child_io_handles[i] != NULL)
+	    CloseHandle(child_io_handles[i]);
+    }
 
     if (success)
     {
@@ -864,7 +866,10 @@ C_process(const char * app, const char * cmdlin, const char ** env,
     }
     else
     {
-	for (i=0; i<3; ++i) _close(io_fds[i]);
+	for (i=0; i<3; ++i) {
+	    if (io_fds[i] != -1)
+		_close(io_fds[i]);
+	}
     }
 
     return success;
diff --git a/tests/posix-tests.scm b/tests/posix-tests.scm
index f227397..4459e36 100644
--- a/tests/posix-tests.scm
+++ b/tests/posix-tests.scm
@@ -32,6 +32,17 @@
 (assert-error (process-execute "false" '("1" "123\x00456")))
 (assert-error (process-execute "false" '("123\x00456") '("foo\x00bar" "blabla") '("lalala" "qux\x00mooh")))
 
+(receive (in out pid)
+    (process "../csi" '("-n" "-e"
+                        "(write 'err (current-error-port)) (write 'ok)"))
+  (assert (equal? 'ok (read in))))
+
+(receive (in out pid err)
+    (process* "../csi" '("-n" "-e"
+                         "(write 'err (current-error-port)) (write 'ok)"))
+  (assert (equal? 'ok (read in)))
+  (assert (equal? 'err (read err))))
+
 (let ((tnpfilpn (create-temporary-file)))
   (let ((tmpfilno (file-open tnpfilpn (+ open/rdwr open/creat)))
         (data "abcde")
-- 
1.7.10.4