[commit: process] master: Ignore broken pipe error in readProcessWithExitCode (#4889) (76fb4b7)

[Paolo Capriotti]

Repository : ssh://darcs.haskell.org//srv/darcs/packages/process

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/76fb4b7e8861dec8054723a3c794c73511d07bb2

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

commit 76fb4b7e8861dec8054723a3c794c73511d07bb2
Author: Paolo Capriotti <p.capriotti at gmail.com>
Date:   Thu May 10 13:41:37 2012 +0100

    Ignore broken pipe error in readProcessWithExitCode (#4889)

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

 System/Process.hs  |   19 ++++++++++++++++---
 tests/T4889.hs     |   10 ++++++++++
 tests/T4889.stdout |    2 ++
 tests/all.T        |    1 +
 4 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/System/Process.hs b/System/Process.hs
index 1acb308..51fba92 100644
--- a/System/Process.hs
+++ b/System/Process.hs
@@ -91,7 +91,7 @@ import System.Exit      ( ExitCode(..) )
 
 #ifdef __GLASGOW_HASKELL__
 #if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Exception ( ioException, IOErrorType(..) )
+import GHC.IO.Exception ( ioException, IOErrorType(..), IOException(..) )
 #else
 import GHC.IOBase       ( ioException, IOErrorType(..) )
 #endif
@@ -449,8 +449,21 @@ readProcessWithExitCode cmd args input =
         waitErr <- forkWait $ C.evaluate $ rnf err
 
         -- now write and flush any input
-        when (not (null input)) $ do hPutStr inh input; hFlush inh
-        hClose inh -- done with stdin
+        let writeInput = do
+              unless (null input) $ do
+                hPutStr inh input
+                hFlush inh
+              hClose inh
+
+#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 611
+        C.catch writeInput $ \e -> case e of
+          IOError { ioe_type = ResourceVanished
+                  , ioe_errno = Just ioe }
+            | Errno ioe == ePIPE -> return ()
+          _ -> throwIO e
+#else
+        writeInput
+#endif
 
         -- wait on the output
         waitOut
diff --git a/tests/T4889.hs b/tests/T4889.hs
new file mode 100644
index 0000000..d8feb47
--- /dev/null
+++ b/tests/T4889.hs
@@ -0,0 +1,10 @@
+module Main where
+
+import System.Process
+
+main :: IO ()
+main = do
+  let text = unlines . map show $ [1..10000 :: Int]
+  (code, out, _) <- readProcessWithExitCode "head" ["-n", "1"] text
+  print code
+  putStr out
diff --git a/tests/T4889.stdout b/tests/T4889.stdout
new file mode 100644
index 0000000..d72cac5
--- /dev/null
+++ b/tests/T4889.stdout
@@ -0,0 +1,2 @@
+ExitSuccess
+1
diff --git a/tests/all.T b/tests/all.T
index 7d25b17..5d53d0b 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -29,3 +29,4 @@ test('4198',
      [''])
 
 test('3994', only_ways(['threaded1','threaded2']), compile_and_run, [''])
+test('T4889', normal, compile_and_run, [''])