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:
Joey Hess 2020-11-18 14:48:50 -04:00
parent 787b39c7c1
commit b483be8548
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 22 additions and 11 deletions

View file

@ -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
View file

@ -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"'

10
test.hs
View file

@ -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
eof <- hIsEOF h
if eof
then return ()
else do
l <- hGetLineUntilExitOrEOF p h
print ("got line", l)
if isJust l
then go h p
else print "at EOF"
go h p