attempt at building with -threaded

Added a modified System.Cmd.Utils, working around bug #681621

Unfortunatly, the test suite still hangs partway through.
Some of the hangs occur within pOpen3 still. Some of the hangs
do not seem to occur within System.Cmd.Utils at all, but in some other
code.

3 files changed, 569 insertions, 1 deletions

diff --git a/Makefile b/Makefile
index 4d5628746..0afb10a7b 100644
--- a/Makefile
+++ b/Makefile
@@ -14,7 +14,7 @@ endif
 
 PREFIX=/usr
 IGNORE=-ignore-package monads-fd -ignore-package monads-tf
-BASEFLAGS=-Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS)
+BASEFLAGS=-threaded -Wall $(IGNORE) -outputdir tmp -IUtility -DWITH_ASSISTANT -DWITH_S3 $(BASEFLAGS_OPTS)
 GHCFLAGS=-O2 $(BASEFLAGS)
 CFLAGS=-Wall
 
diff --git a/System/Cmd/.Utils.hs.swp b/System/Cmd/.Utils.hs.swp
new file mode 100644
index 000000000..65e9e77e4
--- /dev/null
+++ b/System/Cmd/.Utils.hs.swp
diff --git a/System/Cmd/Utils.hs b/System/Cmd/Utils.hs
new file mode 100644
index 000000000..23c2bcedf
--- /dev/null
+++ b/System/Cmd/Utils.hs
@@ -0,0 +1,568 @@
+-- arch-tag: Command utilities main file
+{-# LANGUAGE CPP #-}
+{-
+Copyright (C) 2004-2006 John Goerzen <jgoerzen@complete.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
+-}
+
+{- |
+   Module     : System.Cmd.Utils
+   Copyright  : Copyright (C) 2004-2006 John Goerzen
+   License    : GNU GPL, version 2 or above
+
+   Maintainer : John Goerzen <jgoerzen@complete.org>
+   Stability  : provisional
+   Portability: portable to platforms with POSIX process\/signal tools
+
+Command invocation utilities.
+
+Written by John Goerzen, jgoerzen\@complete.org
+
+Please note: Most of this module is not compatible with Hugs.
+
+Command lines executed will be logged using "System.Log.Logger" at the
+DEBUG level.  Failure messages will be logged at the WARNING level in addition
+to being raised as an exception.  Both are logged under
+\"System.Cmd.Utils.funcname\" -- for instance,
+\"System.Cmd.Utils.safeSystem\".  If you wish to suppress these messages
+globally, you can simply run:
+
+> updateGlobalLogger "System.Cmd.Utils.safeSystem"
+>                     (setLevel CRITICAL)
+
+See also: 'System.Log.Logger.updateGlobalLogger',
+"System.Log.Logger".
+
+It is possible to set up pipelines with these utilities.  Example:
+
+> (pid1, x1) <- pipeFrom "ls" ["/etc"]
+> (pid2, x2) <- pipeBoth "grep" ["x"] x1
+> putStr x2
+> ... the grep output is displayed ...
+> forceSuccess pid2
+> forceSuccess pid1
+
+Remember, when you use the functions that return a String, you must not call
+'forceSuccess' until after all data from the String has been consumed.  Failure
+to wait will cause your program to appear to hang.
+
+Here is an example of the wrong way to do it:
+
+> (pid, x) <- pipeFrom "ls" ["/etc"]
+> forceSuccess pid         -- Hangs; the called program hasn't terminated yet
+> processTheData x
+
+You must instead process the data before calling 'forceSuccess'.
+
+When using the hPipe family of functions, this is probably more obvious.
+
+Most of this module will be incompatible with Windows.
+-}
+
+
+module System.Cmd.Utils(-- * High-Level Tools
+                    PipeHandle(..),
+                    safeSystem,
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+                    forceSuccess,
+#ifndef __HUGS__
+                    posixRawSystem,
+                    forkRawSystem,
+                    -- ** Piping with lazy strings
+                    pipeFrom,
+                    pipeLinesFrom,
+                    pipeTo,
+                    pipeBoth,
+                    -- ** Piping with handles
+                    hPipeFrom,
+                    hPipeTo,
+                    hPipeBoth,
+#endif
+#endif
+                    -- * Low-Level Tools
+                    PipeMode(..),
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+                    pOpen, pOpen3, pOpen3Raw
+#endif
+#endif
+                   )
+where
+
+-- FIXME - largely obsoleted by 6.4 - convert to wrappers.
+
+import System.Exit
+import System.Cmd
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+import System.Posix.IO
+import System.Posix.Process
+import System.Posix.Signals
+import qualified System.Posix.Signals
+#endif
+import System.Posix.Types
+import System.IO
+import System.IO.Error
+import Control.Concurrent(forkIO)
+import Control.Exception(finally)
+
+data PipeMode = ReadFromPipe | WriteToPipe
+
+logbase :: String
+logbase = "System.Cmd.Utils"
+
+{- | Return value from 'pipeFrom', 'pipeLinesFrom', 'pipeTo', or
+'pipeBoth'.  Contains both a ProcessID and the original command that was
+executed.  If you prefer not to use 'forceSuccess' on the result of one
+of these pipe calls, you can use (processID ph), assuming ph is your 'PipeHandle',
+as a parameter to 'System.Posix.Process.getProcessStatus'. -}
+data PipeHandle =
+    PipeHandle { processID :: ProcessID,
+                 phCommand :: FilePath,
+                 phArgs :: [String],
+                 phCreator :: String -- ^ Function that created it
+               }
+    deriving (Eq, Show)
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Like 'pipeFrom', but returns data in lines instead of just a String.
+Shortcut for calling lines on the result from 'pipeFrom'.
+
+Note: this function logs as pipeFrom.
+
+Not available on Windows. -}
+pipeLinesFrom :: FilePath -> [String] -> IO (PipeHandle, [String])
+pipeLinesFrom fp args =
+    do (pid, c) <- pipeFrom fp args
+       return $ (pid, lines c)
+#endif
+#endif
+
+logRunning :: String -> FilePath -> [String] -> IO ()
+logRunning func fp args = return () --debugM (logbase ++ "." ++ func) (showCmd fp args)
+
+warnFail :: [Char] -> FilePath -> [String] -> [Char] -> IO t
+warnFail funcname fp args msg =
+    let m = showCmd fp args ++ ": " ++ msg
+        in do putStrLn m
+              fail m
+
+ddd s a = do
+	putStrLn $ s ++ " start"
+	r <- a
+	putStrLn $ s ++ " end"
+	return r
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Read data from a pipe.  Returns a Handle and a 'PipeHandle'.
+
+When done, you must hClose the handle, and then use either 'forceSuccess' or
+getProcessStatus on the 'PipeHandle'.  Zombies will result otherwise.
+
+This function logs as pipeFrom.
+
+Not available on Windows or with Hugs.
+-}
+hPipeFrom :: FilePath -> [String] -> IO (PipeHandle, Handle)
+hPipeFrom fp args =
+    ddd "hPipeFrom" $ do
+       pipepair <- createPipe
+       let childstuff = do dupTo (snd pipepair) stdOutput
+                           closeFd (fst pipepair)
+                           executeFile fp True args Nothing
+       p <- try (forkProcess childstuff)
+       -- parent
+       pid <- case p of
+                  Right x -> return x
+                  Left e -> warnFail "pipeFrom" fp args $
+                            "Error in fork: " ++ show e
+       closeFd (snd pipepair)
+       h <- fdToHandle (fst pipepair)
+       return (PipeHandle pid fp args "pipeFrom", h)
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Read data from a pipe.  Returns a lazy string and a 'PipeHandle'.
+
+ONLY AFTER the string has been read completely, You must call either
+'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the 'PipeHandle'.
+Zombies will result otherwise.
+
+Not available on Windows.
+-}
+pipeFrom :: FilePath -> [String] -> IO (PipeHandle, String)
+pipeFrom fp args =
+    do (pid, h) <- hPipeFrom fp args
+       c <- hGetContents h
+       return (pid, c)
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Write data to a pipe.  Returns a 'PipeHandle' and a new Handle to write
+to.
+
+When done, you must hClose the handle, and then use either 'forceSuccess' or
+getProcessStatus on the 'PipeHandle'.  Zombies will result otherwise.
+
+This function logs as pipeTo.
+
+Not available on Windows.
+-}
+hPipeTo :: FilePath -> [String] -> IO (PipeHandle, Handle)
+hPipeTo fp args =
+    ddd "hPipeTo" $ do
+       pipepair <- createPipe
+       let childstuff = do dupTo (fst pipepair) stdInput
+                           closeFd (snd pipepair)
+                           executeFile fp True args Nothing
+       p <- try (forkProcess childstuff)
+       -- parent
+       pid <- case p of
+                   Right x -> return x
+                   Left e -> warnFail "pipeTo" fp args $
+                             "Error in fork: " ++ show e
+       closeFd (fst pipepair)
+       h <- fdToHandle (snd pipepair)
+       return (PipeHandle pid fp args "pipeTo", h)
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Write data to a pipe.  Returns a ProcessID.
+
+You must call either
+'System.Posix.Process.getProcessStatus' or 'forceSuccess' on the ProcessID.
+Zombies will result otherwise.
+
+Not available on Windows.
+-}
+pipeTo :: FilePath -> [String] -> String -> IO PipeHandle
+pipeTo fp args message =
+    do (pid, h) <- hPipeTo fp args
+       finally (hPutStr h message)
+               (hClose h)
+       return pid
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Like a combination of 'hPipeTo' and 'hPipeFrom'; returns
+a 3-tuple of ('PipeHandle', Data From Pipe, Data To Pipe).
+
+When done, you must hClose both handles, and then use either 'forceSuccess' or
+getProcessStatus on the 'PipeHandle'.  Zombies will result otherwise.
+
+Hint: you will usually need to ForkIO a thread to handle one of the Handles;
+otherwise, deadlock can result.
+
+This function logs as pipeBoth.
+
+Not available on Windows.
+-}
+hPipeBoth :: FilePath -> [String] -> IO (PipeHandle, Handle, Handle)
+hPipeBoth fp args =
+    ddd "hPipeBoth" $ do
+       frompair <- createPipe
+       topair <- createPipe
+       let childstuff = do dupTo (snd frompair) stdOutput
+                           closeFd (fst frompair)
+                           dupTo (fst topair) stdInput
+                           closeFd (snd topair)
+                           executeFile fp True args Nothing
+       p <- try (forkProcess childstuff)
+       -- parent
+       pid <- case p of
+                   Right x -> return x
+                   Left e -> warnFail "pipeBoth" fp args $
+                             "Error in fork: " ++ show e
+       closeFd (snd frompair)
+       closeFd (fst topair)
+       fromh <- fdToHandle (fst frompair)
+       toh <- fdToHandle (snd topair)
+       return (PipeHandle pid fp args "pipeBoth", fromh, toh)
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Like a combination of 'pipeTo' and 'pipeFrom'; forks an IO thread
+to send data to the piped program, and simultaneously returns its output
+stream.
+
+The same note about checking the return status applies here as with 'pipeFrom'.
+
+Not available on Windows. -}
+pipeBoth :: FilePath -> [String] -> String -> IO (PipeHandle, String)
+pipeBoth fp args message =
+    do (pid, fromh, toh) <- hPipeBoth fp args
+       forkIO $ finally (hPutStr toh message)
+                        (hClose toh)
+       c <- hGetContents fromh
+       return (pid, c)
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+{- | Uses 'System.Posix.Process.getProcessStatus' to obtain the exit status
+of the given process ID.  If the process terminated normally, does nothing.
+Otherwise, raises an exception with an appropriate error message.
+
+This call will block waiting for the given pid to terminate.
+
+Not available on Windows. -}
+forceSuccess :: PipeHandle -> IO ()
+forceSuccess (PipeHandle pid fp args funcname) =
+    let warnfail = warnFail funcname
+        in do status <- getProcessStatus True False pid
+              case status of
+                Nothing -> warnfail fp args $ "Got no process status"
+                Just (Exited (ExitSuccess)) -> return ()
+                Just (Exited (ExitFailure fc)) ->
+                    cmdfailed funcname fp args fc
+                Just (Terminated sig) ->
+                    warnfail fp args $ "Terminated by signal " ++ show sig
+                Just (Stopped sig) ->
+                    warnfail fp args $ "Stopped by signal " ++ show sig
+#endif
+
+{- | Invokes the specified command in a subprocess, waiting for the result.
+If the command terminated successfully, return normally.  Otherwise,
+raises a userError with the problem.
+
+Implemented in terms of 'posixRawSystem' where supported, and System.Posix.rawSystem otherwise.
+-}
+safeSystem :: FilePath -> [String] -> IO ()
+safeSystem command args =
+    ddd "safeSystem" $ do
+#if defined(__HUGS__) || defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__)
+       ec <- rawSystem command args
+       case ec of
+            ExitSuccess -> return ()
+            ExitFailure fc -> cmdfailed "safeSystem" command args fc
+#else
+       ec <- posixRawSystem command args
+       case ec of
+            Exited ExitSuccess -> return ()
+            Exited (ExitFailure fc) -> cmdfailed "safeSystem" command args fc
+            Terminated s -> cmdsignalled "safeSystem" command args s
+            Stopped s -> cmdsignalled "safeSystem" command args s
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Invokes the specified command in a subprocess, waiting for the result.
+Return the result status.  Never raises an exception.  Only available
+on POSIX platforms.
+
+Like system(3), this command ignores SIGINT and SIGQUIT and blocks SIGCHLD
+during its execution.
+
+Logs as System.Cmd.Utils.posixRawSystem -}
+posixRawSystem :: FilePath -> [String] -> IO ProcessStatus
+posixRawSystem program args =
+    ddd "posixRawSystem" $ do
+       oldint <- installHandler sigINT Ignore Nothing
+       oldquit <- installHandler sigQUIT Ignore Nothing
+       let sigset = addSignal sigCHLD emptySignalSet
+       oldset <- getSignalMask
+       blockSignals sigset
+       childpid <- forkProcess (childaction oldint oldquit oldset)
+
+       mps <- getProcessStatus True False childpid
+       restoresignals oldint oldquit oldset
+       let retval = case mps of
+                      Just x -> x
+                      Nothing -> error "Nothing returned from getProcessStatus"
+       return retval
+
+    where childaction oldint oldquit oldset =
+              do restoresignals oldint oldquit oldset
+                 executeFile program True args Nothing
+          restoresignals oldint oldquit oldset =
+              do installHandler sigINT oldint Nothing
+                 installHandler sigQUIT oldquit Nothing
+                 setSignalMask oldset
+
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Invokes the specified command in a subprocess, without waiting for
+the result.  Returns the PID of the subprocess -- it is YOUR responsibility
+to use getProcessStatus or getAnyProcessStatus on that at some point.  Failure
+to do so will lead to resource leakage (zombie processes).
+
+This function does nothing with signals.  That too is up to you.
+
+Logs as System.Cmd.Utils.forkRawSystem -}
+forkRawSystem :: FilePath -> [String] -> IO ProcessID
+forkRawSystem program args = ddd "forkRawSystem" $
+    do
+       forkProcess childaction
+    where
+      childaction = executeFile program True args Nothing
+
+#endif
+#endif
+
+cmdfailed :: String -> FilePath -> [String] -> Int -> IO a
+cmdfailed funcname command args failcode = do
+    let errormsg = "Command " ++ command ++ " " ++ (show args) ++
+            " failed; exit code " ++ (show failcode)
+    let e = userError (errormsg)
+    putStrLn errormsg
+    ioError e
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+cmdsignalled :: String -> FilePath -> [String] -> Signal -> IO a
+cmdsignalled funcname command args failcode = do
+    let errormsg = "Command " ++ command ++ " " ++ (show args) ++
+            " failed due to signal " ++ (show failcode)
+    let e = userError (errormsg)
+    putStrLn errormsg
+    ioError e
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Open a pipe to the specified command.
+
+Passes the handle on to the specified function.
+
+The 'PipeMode' specifies what you will be doing.  That is, specifing 'ReadFromPipe'
+sets up a pipe from stdin, and 'WriteToPipe' sets up a pipe from stdout.
+
+Not available on Windows.
+ -}
+pOpen :: PipeMode -> FilePath -> [String] ->
+         (Handle -> IO a) -> IO a
+pOpen pm fp args func = ddd "pOpen" $
+        do
+        pipepair <- createPipe
+        case pm of
+         ReadFromPipe -> do
+                         let callfunc _ = do
+                                        closeFd (snd pipepair)
+                                        h <- fdToHandle (fst pipepair)
+                                        x <- func h
+                                        hClose h
+                                        return $! x
+                         pOpen3 Nothing (Just (snd pipepair)) Nothing fp args
+                                callfunc (closeFd (fst pipepair))
+         WriteToPipe -> do
+                        let callfunc _ = do
+                                       closeFd (fst pipepair)
+                                       h <- fdToHandle (snd pipepair)
+                                       x <- func h
+                                       hClose h
+                                       return $! x
+                        pOpen3 (Just (fst pipepair)) Nothing Nothing fp args
+                               callfunc (closeFd (snd pipepair))
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Runs a command, redirecting things to pipes.
+
+Not available on Windows.
+
+Note that you may not use the same fd on more than one item.  If you
+want to redirect stdout and stderr, dup it first.
+-}
+pOpen3 :: Maybe Fd                      -- ^ Send stdin to this fd
+       -> Maybe Fd                      -- ^ Get stdout from this fd
+       -> Maybe Fd                      -- ^ Get stderr from this fd
+       -> FilePath                      -- ^ Command to run
+       -> [String]                      -- ^ Command args
+       -> (ProcessID -> IO a)           -- ^ Action to run in parent
+       -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
+       -> IO a
+pOpen3 pin pout perr fp args func childfunc = ddd "pOpen3" $
+    do pid <- pOpen3Raw pin pout perr fp args childfunc
+       putStrLn "got pid"
+       retval <- func $! pid
+       putStrLn "got retval"
+       let rv = seq retval retval
+       forceSuccess (PipeHandle (seq retval pid) fp args "pOpen3")
+       putStrLn "process finished"
+       return rv
+#endif
+#endif
+
+#if !(defined(mingw32_HOST_OS) || defined(mingw32_TARGET_OS) || defined(__MINGW32__))
+#ifndef __HUGS__
+{- | Runs a command, redirecting things to pipes.
+
+Not available on Windows.
+
+Returns immediately with the PID of the child.  Using 'waitProcess' on it
+is YOUR responsibility!
+
+Note that you may not use the same fd on more than one item.  If you
+want to redirect stdout and stderr, dup it first.
+-}
+pOpen3Raw :: Maybe Fd                      -- ^ Send stdin to this fd
+       -> Maybe Fd                      -- ^ Get stdout from this fd
+       -> Maybe Fd                      -- ^ Get stderr from this fd
+       -> FilePath                      -- ^ Command to run
+       -> [String]                      -- ^ Command args
+       -> IO ()                         -- ^ Action to run in child before execing (if you don't need something, set this to @return ()@) -- IGNORED IN HUGS
+       -> IO ProcessID
+pOpen3Raw pin pout perr fp args childfunc =
+    let mayberedir Nothing _ = return ()
+        mayberedir (Just fromfd) tofd = do
+                                        dupTo fromfd tofd
+                                        closeFd fromfd
+                                        return ()
+        childstuff = do
+                     mayberedir pin stdInput
+                     mayberedir pout stdOutput
+                     mayberedir perr stdError
+                     childfunc
+                     executeFile fp True args Nothing
+{-
+        realfunc p = do
+                     System.Posix.Signals.installHandler
+                           System.Posix.Signals.sigPIPE
+                           System.Posix.Signals.Ignore
+                           Nothing
+                     func p
+-}
+        in
+        ddd "pOpen3Raw" $
+        do
+        p <- try (forkProcess childstuff)
+        pid <- case p of
+                Right x -> return x
+                Left e -> fail ("Error in fork: " ++ (show e))
+        return pid
+
+#endif
+#endif
+
+showCmd :: FilePath -> [String] -> String
+showCmd fp args = fp ++ " " ++ show args