port processTranscript to Windows (suboptimal implementation)
This commit is contained in:
parent
10a39a8796
commit
413e56ff9b
1 changed files with 36 additions and 1 deletions
|
@ -161,6 +161,8 @@ createBackgroundProcess p a = a =<< createProcess p
|
||||||
- whether it succeeded or failed. -}
|
- whether it succeeded or failed. -}
|
||||||
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
|
processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
|
||||||
#ifndef mingw32_HOST_OS
|
#ifndef mingw32_HOST_OS
|
||||||
|
{- This implementation interleves stdout and stderr in exactly the order
|
||||||
|
- the process writes them. -}
|
||||||
processTranscript cmd opts input = do
|
processTranscript cmd opts input = do
|
||||||
(readf, writef) <- createPipe
|
(readf, writef) <- createPipe
|
||||||
readh <- fdToHandle readf
|
readh <- fdToHandle readf
|
||||||
|
@ -195,7 +197,40 @@ processTranscript cmd opts input = do
|
||||||
ok <- checkSuccessProcess pid
|
ok <- checkSuccessProcess pid
|
||||||
return (transcript, ok)
|
return (transcript, ok)
|
||||||
#else
|
#else
|
||||||
processTranscript = error "processTranscript TODO"
|
{- This implementation for Windows puts stderr after stdout. -}
|
||||||
|
processTranscript cmd opts input = do
|
||||||
|
p@(_, _, _, pid) <- createProcess $
|
||||||
|
(proc cmd opts)
|
||||||
|
{ std_in = if isJust input then CreatePipe else Inherit
|
||||||
|
, std_out = CreatePipe
|
||||||
|
, std_err = CreatePipe
|
||||||
|
}
|
||||||
|
|
||||||
|
getout <- mkreader (stdoutHandle p)
|
||||||
|
geterr <- mkreader (stderrHandle p)
|
||||||
|
|
||||||
|
case input of
|
||||||
|
Just s -> do
|
||||||
|
let inh = stdinHandle p
|
||||||
|
unless (null s) $ do
|
||||||
|
hPutStr inh s
|
||||||
|
hFlush inh
|
||||||
|
hClose inh
|
||||||
|
Nothing -> return ()
|
||||||
|
|
||||||
|
transcript <- (++) <$> getout <*> geterr
|
||||||
|
ok <- checkSuccessProcess pid
|
||||||
|
return (transcript, ok)
|
||||||
|
where
|
||||||
|
mkreader h = do
|
||||||
|
s <- hGetContents h
|
||||||
|
v <- newEmptyMVar
|
||||||
|
void $ forkIO $ do
|
||||||
|
E.evaluate (length s)
|
||||||
|
putMVar v ()
|
||||||
|
return $ do
|
||||||
|
takeMVar v
|
||||||
|
return s
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
{- Runs a CreateProcessRunner, on a CreateProcess structure, that
|
{- Runs a CreateProcessRunner, on a CreateProcess structure, that
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue