[commit: packages/process] master: T11100: modified pipe functions. Need some cleanup (074ba27)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/process

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/074ba275f98002d99d2c49e5380a96ae991abb86/process

>---------------------------------------------------------------

commit 074ba275f98002d99d2c49e5380a96ae991abb86
Author: Tamar Christina <tamar at zhox.com>
Date:   Wed Jan 20 06:47:35 2016 +0100

    T11100: modified pipe functions. Need some cleanup


>---------------------------------------------------------------

074ba275f98002d99d2c49e5380a96ae991abb86
 System/Process.hsc          |  1 +
 System/Process/Internals.hs |  1 +
 System/Process/Windows.hsc  | 21 +++++++++++++----
 cbits/pipes.c               | 57 +++++++++++++++++++++++++++++++++++++++++++++
 include/pipes.h             | 18 ++++++++++++++
 process.cabal               |  6 +++++
 6 files changed, 100 insertions(+), 4 deletions(-)

diff --git a/System/Process.hsc b/System/Process.hsc
index 6b870fd..579c197 100644
--- a/System/Process.hsc
+++ b/System/Process.hsc
@@ -57,6 +57,7 @@ module System.Process (
 
     -- Interprocess communication
     createPipe,
+    createPipeInternalFd,
 
     -- * Old deprecated functions
     -- | These functions pre-date 'createProcess' which is much more
diff --git a/System/Process/Internals.hs b/System/Process/Internals.hs
index ef8ff8f..a3fb0d8 100644
--- a/System/Process/Internals.hs
+++ b/System/Process/Internals.hs
@@ -38,6 +38,7 @@ module System.Process.Internals (
     withFilePathException, withCEnvironment,
     translate,
     createPipe,
+    createPipeInternalFd,
     interruptProcessGroupOf,
     ) where
 
diff --git a/System/Process/Windows.hsc b/System/Process/Windows.hsc
index a984bae..613656a 100644
--- a/System/Process/Windows.hsc
+++ b/System/Process/Windows.hsc
@@ -10,6 +10,7 @@ module System.Process.Windows
     , stopDelegateControlC
     , isDefaultSignal
     , createPipeInternal
+    , createPipeInternalFd
     , interruptProcessGroupOfInternal
     ) where
 
@@ -245,20 +246,32 @@ isDefaultSignal = const False
 createPipeInternal :: IO (Handle, Handle)
 createPipeInternal = do
     (readfd, writefd) <- allocaArray 2 $ \ pfds -> do
-        throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
-        readfd <- peek pfds
-        writefd <- peekElemOff pfds 1
-        return (readfd, writefd)
+            throwErrnoIfMinus1_ "_pipe" $ c__pipe pfds 2 (#const _O_BINARY)
+            readfd <- peek pfds
+            writefd <- peekElemOff pfds 1
+            return (readfd, writefd)
     (do readh <- fdToHandle readfd
         writeh <- fdToHandle writefd
         return (readh, writeh)) `onException` (close' readfd >> close' writefd)
         
+createPipeInternalFd :: IO (FD, FD)
+createPipeInternalFd = do
+    allocaArray 2 $ \ pfds -> do
+        throwErrnoIfMinus1_ "_pipe" $ c__pipe2 pfds 2 (#const _O_BINARY)
+        readfd <- peek pfds
+        writefd <- peekElemOff pfds 1
+        return (readfd, writefd)
+
+
 close' :: CInt -> IO ()
 close' = throwErrnoIfMinus1_ "_close" . c__close
 
 foreign import ccall "io.h _pipe" c__pipe ::
     Ptr CInt -> CUInt -> CInt -> IO CInt
     
+foreign import ccall "pipes.h createInheritablePipe" c__pipe2 ::
+    Ptr CInt -> CUInt -> CInt -> IO CInt
+
 foreign import ccall "io.h _close" c__close ::
     CInt -> IO CInt
 
diff --git a/cbits/pipes.c b/cbits/pipes.c
new file mode 100644
index 0000000..2ba9265
--- /dev/null
+++ b/cbits/pipes.c
@@ -0,0 +1,57 @@
+/* ----------------------------------------------------------------------------
+   (c) The University of Glasgow 2004
+
+   Support for System.Process
+   ------------------------------------------------------------------------- */
+   
+#include "pipes.h"
+
+BOOL createInheritablePipe(int *phandles, unsigned int psize, int textmode) {
+    HANDLE hTemporaryIn  = NULL;
+    HANDLE hTemporaryOut = NULL;
+    
+    BOOL isInheritableOut = TRUE;
+    BOOL isInheritableIn = TRUE;
+
+    /* Create the anon pipe with both ends inheritable */
+    if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, NULL, 0))
+    {
+        maperrno();
+        phandles[0]  = NULL;
+        phandles[1]  = NULL;
+        return FALSE;
+    }
+
+    if (isInheritableIn) {
+        // SetHandleInformation requires at least Win2k
+        if (!SetHandleInformation(hTemporaryIn,
+                                  HANDLE_FLAG_INHERIT,
+                                  HANDLE_FLAG_INHERIT))
+        {
+            maperrno();
+            phandles[0]   = NULL;
+            phandles[1]  = NULL;
+            CloseHandle(hTemporaryIn);
+            CloseHandle(hTemporaryOut);
+            return FALSE;
+        }
+    }
+    phandles[0]  = _open_osfhandle((int)hTemporaryIn, textmode);
+
+    if (isInheritableOut) {
+        if (!SetHandleInformation(hTemporaryOut,
+                                  HANDLE_FLAG_INHERIT,
+                                  HANDLE_FLAG_INHERIT))
+        {
+            maperrno();
+            phandles[0]   = NULL;
+            phandles[1]  = NULL;
+            CloseHandle(hTemporaryIn);
+            CloseHandle(hTemporaryOut);
+            return FALSE;
+        }
+    }
+    phandles[1]  = _open_osfhandle((int)hTemporaryOut, textmode);
+
+    return TRUE;
+}
\ No newline at end of file
diff --git a/include/pipes.h b/include/pipes.h
new file mode 100644
index 0000000..36e2545
--- /dev/null
+++ b/include/pipes.h
@@ -0,0 +1,18 @@
+/* ----------------------------------------------------------------------------
+   (c) The University of Glasgow 2004
+
+   Interface for code in pipes.c (providing support for System.Process)
+   ------------------------------------------------------------------------- */
+
+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
+#define UNICODE
+#include <windows.h>
+#include <stdlib.h>
+#include <io.h>
+#endif
+
+#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
+
+extern BOOL createInheritablePipe(int *phandles, unsigned int psize, int textmode);
+
+#endif
diff --git a/process.cabal b/process.cabal
index ee69285..c0918f2 100644
--- a/process.cabal
+++ b/process.cabal
@@ -51,6 +51,12 @@ library
         build-depends: Win32 >=2.2 && < 2.4
         extra-libraries: kernel32
         cpp-options: -DWINDOWS
+        c-sources: 
+            cbits/pipes.c
+        includes:
+            pipes.h
+        install-includes:
+            pipes.h
     else
         other-modules: System.Process.Posix
         build-depends: unix >= 2.5 && < 2.8