From a0aab76ae762614041720dd55d63ed3e0b7c1c94 Mon Sep 17 00:00:00 2001
From: Joey Hess <joey@kitenet.net>
Date: Tue, 10 Dec 2013 15:46:12 -0400
Subject: sync from git-annex

---
 Utility/Process.hs         | 10 ++++++++--
 Utility/Rsync.hs           |  3 ++-
 Utility/ThreadScheduler.hs |  7 +++++--
 3 files changed, 15 insertions(+), 5 deletions(-)

(limited to 'Utility')

diff --git a/Utility/Process.hs b/Utility/Process.hs
index 398e8a3..03cbe95 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -22,6 +22,7 @@ module Utility.Process (
 	createProcessChecked,
 	createBackgroundProcess,
 	processTranscript,
+	processTranscript',
 	withHandle,
 	withBothHandles,
 	withQuietOutput,
@@ -162,10 +163,13 @@ createBackgroundProcess p a = a =<< createProcess p
  - returns a transcript combining its stdout and stderr, and
  - whether it succeeded or failed. -}
 processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool)
+processTranscript cmd opts input = processTranscript' cmd opts Nothing input
+
+processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool)
 #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 environ input = do
 	(readf, writef) <- createPipe
 	readh <- fdToHandle readf
 	writeh <- fdToHandle writef
@@ -174,6 +178,7 @@ processTranscript cmd opts input = do
 			{ std_in = if isJust input then CreatePipe else Inherit
 			, std_out = UseHandle writeh
 			, std_err = UseHandle writeh
+			, env = environ
 			}
 	hClose writeh
 
@@ -195,12 +200,13 @@ processTranscript cmd opts input = do
 	return (transcript, ok)
 #else
 {- This implementation for Windows puts stderr after stdout. -}
-processTranscript cmd opts input = do
+processTranscript' cmd opts environ input = do
 	p@(_, _, _, pid) <- createProcess $
 		(proc cmd opts)
 			{ std_in = if isJust input then CreatePipe else Inherit
 			, std_out = CreatePipe
 			, std_err = CreatePipe
+			, env = environ
 			}
 
 	getout <- mkreader (stdoutHandle p)
diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs
index 5f322a0..2c5e39b 100644
--- a/Utility/Rsync.hs
+++ b/Utility/Rsync.hs
@@ -67,7 +67,8 @@ rsyncParamsFixup = map fixup
  -}
 rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool
 rsyncProgress meterupdate params = do
-	r <- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 [])
+	r <- catchBoolIO $ 
+		withHandle StdoutHandle createProcessSuccess p (feedprogress 0 [])
 	{- For an unknown reason, piping rsync's output like this does
 	 - causes it to run a second ssh process, which it neglects to wait
 	 - on. Reap the resulting zombie. -}
diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs
index c3e871c..dbb6cb3 100644
--- a/Utility/ThreadScheduler.hs
+++ b/Utility/ThreadScheduler.hs
@@ -53,17 +53,20 @@ unboundDelay time = do
 {- Pauses the main thread, letting children run until program termination. -}
 waitForTermination :: IO ()
 waitForTermination = do
+#ifdef mingw32_HOST_OS
+	runEvery (Seconds 600) $
+		void getLine
+#else
 	lock <- newEmptyMVar
-#ifndef mingw32_HOST_OS
 	let check sig = void $
 		installHandler sig (CatchOnce $ putMVar lock ()) Nothing
 	check softwareTermination
 #ifndef __ANDROID__
 	whenM (queryTerminal stdInput) $
 		check keyboardSignal
-#endif
 #endif
 	takeMVar lock
+#endif
 
 oneSecond :: Microseconds
 oneSecond = 1000000
-- 
cgit v1.2.3