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.
This commit is contained in:
parent
787b39c7c1
commit
b483be8548
3 changed files with 22 additions and 11 deletions
|
@ -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
|
||||
|
|
3
bench
3
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"'
|
||||
|
|
14
test.hs
14
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
|
||||
|
||||
|
|
Loading…
Reference in a new issue