Commit 8e67327e authored by Mikhail Glushenkov's avatar Mikhail Glushenkov
Browse files

Use the delegate_ctlc feature from process >= 1.2.

Allows to remove code copied to D.S.Utils from System.Process.Internal.
parent 75f8651d
......@@ -119,15 +119,15 @@ source-repository head
library
build-depends:
base >= 4 && < 5,
deepseq >= 1.3 && < 1.4,
filepath >= 1 && < 1.4,
directory >= 1 && < 1.3,
process >= 1.0.1.1 && < 1.3,
time >= 1.1 && < 1.5,
containers >= 0.1 && < 0.6,
array >= 0.1 && < 0.6,
pretty >= 1 && < 1.2,
base >= 4 && < 5,
deepseq >= 1.3 && < 1.4,
filepath >= 1 && < 1.4,
directory >= 1 && < 1.3,
process >= 1.2 && < 1.3,
time >= 1.1 && < 1.5,
containers >= 0.1 && < 0.6,
array >= 0.1 && < 0.6,
pretty >= 1 && < 1.2,
bytestring >= 0.9
if !os(windows)
......
......@@ -149,7 +149,7 @@ import System.Directory
import System.IO
( Handle, openFile, openBinaryFile, openBinaryTempFile
, IOMode(ReadMode), hSetBinaryMode
, hGetContents, stdin, stderr, stdout, hPutStr, hFlush, hClose )
, hGetContents, stderr, stdout, hPutStr, hFlush, hClose )
import System.IO.Error as IO.Error
( isDoesNotExistError, isAlreadyExistsError
, ioeSetFileName, ioeGetFileName, ioeGetErrorString )
......@@ -169,23 +169,12 @@ import Distribution.Version
(Version(..))
import Control.Exception (IOException, evaluate, throwIO)
import System.Process (rawSystem)
import qualified System.Process as Process (CreateProcess(..))
import Control.Concurrent (forkIO)
import System.Process (runInteractiveProcess, waitForProcess, proc,
StdStream(..))
#if __GLASGOW_HASKELL__ >= 702
import System.Process (showCommandForUser)
#endif
#ifndef mingw32_HOST_OS
import System.Posix.Signals (installHandler, sigINT, sigQUIT, Handler(..))
import System.Process.Internals (defaultSignal, runGenProcess_)
#else
import System.Process (createProcess)
#endif
import qualified System.Process as Process
( CreateProcess(..), StdStream(..), proc)
import System.Process
( createProcess, rawSystem, runInteractiveProcess
, showCommandForUser, waitForProcess)
import Distribution.Compat.CopyFile
( copyFile, copyOrdinaryFile, copyExecutableFile
, setFileOrdinary, setFileExecutable, setDirOrdinary )
......@@ -345,12 +334,7 @@ maybeExit cmd = do
printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO ()
printRawCommandAndArgs verbosity path args
| verbosity >= deafening = print (path, args)
| verbosity >= verbose =
#if __GLASGOW_HASKELL__ >= 702
putStrLn $ showCommandForUser path args
#else
putStrLn $ unwords (path : args)
#endif
| verbosity >= verbose = putStrLn $ showCommandForUser path args
| otherwise = return ()
printRawCommandAndArgsAndEnv :: Verbosity
......@@ -365,39 +349,6 @@ printRawCommandAndArgsAndEnv verbosity path args env
| otherwise = return ()
-- This is taken directly from the process package.
-- The reason we need it is that runProcess doesn't handle ^C in the same
-- way that rawSystem handles it, but rawSystem doesn't allow us to pass
-- an environment.
syncProcess :: String -> Process.CreateProcess -> IO ExitCode
#if mingw32_HOST_OS
syncProcess _fun c = do
(_,_,_,p) <- createProcess c
waitForProcess p
#else
syncProcess fun c = do
-- The POSIX version of system needs to do some manipulation of signal
-- handlers. Since we're going to be synchronously waiting for the child,
-- we want to ignore ^C in the parent, but handle it the default way
-- in the child (using SIG_DFL isn't really correct, it should be the
-- original signal handler, but the GHC RTS will have already set up
-- its own handler and we don't want to use that).
r <- Exception.bracket (installHandlers) (restoreHandlers) $
(\_ -> do (_,_,_,p) <- runGenProcess_ fun c
(Just defaultSignal) (Just defaultSignal)
waitForProcess p)
return r
where
installHandlers = do
old_int <- installHandler sigINT Ignore Nothing
old_quit <- installHandler sigQUIT Ignore Nothing
return (old_int, old_quit)
restoreHandlers (old_int, old_quit) = do
_ <- installHandler sigINT old_int Nothing
_ <- installHandler sigQUIT old_quit Nothing
return ()
#endif /* mingw32_HOST_OS */
-- Exit with the same exit code if the subcommand fails
rawSystemExit :: Verbosity -> FilePath -> [String] -> IO ()
rawSystemExit verbosity path args = do
......@@ -425,8 +376,10 @@ rawSystemExitWithEnv :: Verbosity
rawSystemExitWithEnv verbosity path args env = do
printRawCommandAndArgsAndEnv verbosity path args env
hFlush stdout
exitcode <- syncProcess "rawSystemExitWithEnv" (proc path args)
{ Process.env = Just env }
(_,_,_,ph) <- createProcess $
(Process.proc path args) { Process.env = (Just env)
, Process.delegate_ctlc = True }
exitcode <- waitForProcess ph
unless (exitcode == ExitSuccess) $ do
debug verbosity $ path ++ " returned " ++ show exitcode
exitWith exitcode
......@@ -445,26 +398,20 @@ rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do
maybe (printRawCommandAndArgs verbosity path args)
(printRawCommandAndArgsAndEnv verbosity path args) menv
hFlush stdout
exitcode <- syncProcess "rawSystemIOWithEnv" (proc path args)
{ Process.cwd = mcwd
, Process.env = menv
, Process.std_in = mbToStd inp
, Process.std_out = mbToStd out
, Process.std_err = mbToStd err }
`Exception.finally` (mapM_ maybeClose [inp, out, err])
(_,_,_,ph) <- createProcess $
(Process.proc path args) { Process.cwd = mcwd
, Process.env = menv
, Process.std_in = mbToStd inp
, Process.std_out = mbToStd out
, Process.std_err = mbToStd err
, Process.delegate_ctlc = True }
exitcode <- waitForProcess ph
unless (exitcode == ExitSuccess) $ do
debug verbosity $ path ++ " returned " ++ show exitcode
return exitcode
where
-- Also taken from System.Process
maybeClose :: Maybe Handle -> IO ()
maybeClose (Just hdl)
| hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl
maybeClose _ = return ()
mbToStd :: Maybe Handle -> StdStream
mbToStd Nothing = Inherit
mbToStd (Just hdl) = UseHandle hdl
mbToStd :: Maybe Handle -> Process.StdStream
mbToStd = maybe Process.Inherit Process.UseHandle
-- | Run a command and return its output.
--
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment