newline mode (mis)handling for windows

Unfortunately, there is no hGetNewLineMode. This seems like an oversight
that should be fixed in ghc, but for now, I paper over it with a windows
hack.

diff --git a/Utility/Process.hs b/Utility/Process.hs
index a7e1b12f7ceedefc4a91ca8cdb07695e369f8a35..755226471067757cc4ecc58566dc15fedc9ec3a4 100644 (file)
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -43,10 +43,8 @@ import System.Exit
 import System.IO
 import System.Log.Logger
 import Control.Monad.IO.Class
-import Control.Concurrent
 import Control.Concurrent.Async
 import qualified Data.ByteString as S
-import GHC.IO.Handle (hWaitForInput)
 
 data StdHandle = StdinHandle | StdoutHandle | StderrHandle
        deriving (Eq)
@@ -248,6 +246,11 @@ cleanupProcess (mb_stdin, mb_stdout, mb_stderr, pid) = do
  - In that situation, this will detect when the process has exited,
  - and avoid blocking forever. But will still return anything the process
  - buffered to the handle before exiting.
+ -
+ - Note on newline mode: This ignores whatever newline mode is configured
+ - for the handle, because there is no way to query that. On Windows,
+ - it will remove any \r coming before the \n. On other platforms,
+ - it does not treat \r specially.
  -}
 hGetLineUntilExitOrEOF :: ProcessHandle -> Handle -> IO (Maybe String)
 hGetLineUntilExitOrEOF ph h = go []
@@ -288,10 +291,17 @@ hGetLineUntilExitOrEOF ph h = go []
        getloop buf cont =
                getchar >>= \case
                        Just c
-                               | c == '\n' -> return (Just (reverse buf))
+                               | c == '\n' -> return (Just (gotline buf))
                                | otherwise -> cont (c:buf)
                        Nothing -> eofwithnolineend buf
 
+#ifndef mingw32_HOST_OS
+       gotline buf = reverse buf
+#else
+       gotline ('\r':buf) = reverse buf
+       gotline buf = reverse buf
+#endif
+
        eofwithnolineend buf = return $
                if null buf 
                        then Nothing -- no line read

diff --git a/bench b/bench
index 52e2d78116fb6ce24f8935eb69950f2a05e5b161..98f1e9eda52e8042a550168e469e1d6781ae1b3f 100755 (executable)
--- a/bench
+++ b/bench
@@ -1,5 +1,2 @@
 #!/bin/sh
-ssh -fN -o ControlMaster=auto -o ControlPersist=15m -o ControlPath=./socket localhost
-echo foo >&2
-sleep 2
 perl -e 'print STDERR "blah\n" for 1..100; print STDERR "final\n"'

diff --git a/test.hs b/test.hs
index 188f92a333e23fe09ec221f8d6b0b53e4825b43d..9bda99a1c73e180451baa73bceb0de103c6d9cc6 100644 (file)
--- a/test.hs
+++ b/test.hs
@@ -6,14 +6,18 @@ import Control.Concurrent.Async
 main = do
        (Nothing, Nothing, Just h, p) <- createProcess $ (proc "./bench" [])
                { std_err = CreatePipe }
+       hSetNewlineMode h universalNewlineMode
        t <- async $ go h p
        exitcode <- waitForProcess p
        print ("process exited", exitcode)
        wait t
   where
        go h p = do
-               l <- hGetLineUntilExitOrEOF p h
-               print ("got line", l)
-               if isJust l
-                       then go h p
-                       else print "at EOF"
+               eof <- hIsEOF h
+               if eof
+                       then return ()
+                       else do
+                               l <- hGetLineUntilExitOrEOF p h
+                               print ("got line", l)
+                               go h p
+