From 107e84293bb60b82233b1177eae66ed33b665af1 Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 13 Dec 2007 15:40:56 +0000 Subject: [PATCH] FIX #1963: catch Ctrl-C and clean up properly --- utils/ghc-pkg/Main.hs | 81 ++++++++++++++++++++++++++++++++++++------------ utils/ghc-pkg/Makefile | 4 +++ 2 files changed, 65 insertions(+), 20 deletions(-) diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index ef5cb39..bdd9c80 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -41,16 +41,22 @@ import qualified Control.Exception as Exception import Data.Maybe import Data.Char ( isSpace, toLower ) -import Monad -import Directory -import System ( getArgs, getProgName, getEnv, exitWith, ExitCode(..) ) +import Control.Monad +import System.Directory ( doesDirectoryExist, getDirectoryContents, + doesFileExist, renameFile, removeFile ) +import System.Exit ( exitWith, ExitCode(..) ) +import System.Environment ( getArgs, getProgName, getEnv ) import System.IO import System.IO.Error (try) import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub ) +import Control.Concurrent #ifdef mingw32_HOST_OS import Foreign import Foreign.C.String +import GHC.ConsoleHandler +#else +import System.Posix #endif import IO ( isPermissionError, isDoesNotExistError ) @@ -123,7 +129,7 @@ deprecFlags = [ ] ourCopyright :: String -ourCopyright = "GHC package manager version " ++ version ++ "\n" +ourCopyright = "GHC package manager version " ++ Version.version ++ "\n" usageHeader :: String -> String usageHeader prog = substProg prog $ @@ -194,6 +200,7 @@ data Force = ForceAll | ForceFiles | NoForce runit :: [Flag] -> [String] -> IO () runit cli nonopts = do + installSignalHandlers -- catch ^C and clean up prog <- getProgramName let force @@ -310,7 +317,7 @@ getPkgDatabases modify flags = do appdir <- getAppUserDataDirectory "ghc" let - subdir = targetARCH ++ '-':targetOS ++ '-':version + subdir = targetARCH ++ '-':targetOS ++ '-':Version.version archdir = appdir subdir user_conf = archdir "package.conf" user_exists <- doesFileExist user_conf @@ -321,7 +328,7 @@ getPkgDatabases modify flags = do | modify || user_exists = user_conf : global_confs ++ [global_conf] | otherwise = global_confs ++ [global_conf] - e_pkg_path <- try (getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = case e_pkg_path of Left _ -> sys_databases @@ -377,8 +384,8 @@ readParseDatabase filename = do str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig let packages = read str Exception.evaluate packages - `Exception.catch` \_ -> - die (filename ++ ": parse error in package config file") + `Exception.catch` \e-> + die ("error while parsing " ++ filename ++ ": " ++ show e) return (filename,packages) emptyPackageConfig :: String @@ -682,17 +689,22 @@ savingOldConfig filename io = Exception.block $ do "to", show oldFile]) ioError err return False - hPutStrLn stdout "done." - io `catch` \e -> do - hPutStrLn stderr (show e) - hPutStr stdout ("\nWARNING: an error was encountered while writing" + (do hPutStrLn stdout "done."; io) + `Exception.catch` \e -> do + hPutStr stdout ("WARNING: an error was encountered while writing " ++ "the new configuration.\n") - when restore_on_error $ do - hPutStr stdout "Attempting to restore the old configuration..." - do renameFile oldFile filename - hPutStrLn stdout "done." - `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err) - ioError e + if restore_on_error + then do + hPutStr stdout "Attempting to restore the old configuration... " + do renameFile oldFile filename + hPutStrLn stdout "done." + `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err) + else do + -- file did not exist before, so the new one which + -- might be partially complete. + try (removeFile filename) + return () + Exception.throwIO e ----------------------------------------------------------------------------- -- Sanity-check a new package config, and automatically build GHCi libs @@ -877,7 +889,7 @@ expandEnvVars str force = go str "" lookupEnvVar :: String -> IO String lookupEnvVar nm = - catch (System.getEnv nm) + catch (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -920,7 +932,7 @@ my_head s [] = error s my_head s (x:xs) = x ----------------------------------------- --- Cut and pasted from ghc/compiler/SysTools +-- Cut and pasted from ghc/compiler/main/SysTools #if defined(mingw32_HOST_OS) subst :: Char -> Char -> String -> String @@ -950,3 +962,32 @@ foreign import stdcall unsafe "GetModuleFileNameA" getExecDir :: String -> IO (Maybe String) getExecDir _ = return Nothing #endif + +----------------------------------------- +-- Adapted from ghc/compiler/utils/Panic + +installSignalHandlers :: IO () +installSignalHandlers = do + threadid <- myThreadId + let + interrupt = throwTo threadid (Exception.ErrorCall "interrupted") + -- +#if !defined(mingw32_HOST_OS) + installHandler sigQUIT (Catch interrupt) Nothing + installHandler sigINT (Catch interrupt) Nothing + return () +#elif __GLASGOW_HASKELL__ >= 603 + -- GHC 6.3+ has support for console events on Windows + -- NOTE: running GHCi under a bash shell for some reason requires + -- you to press Ctrl-Break rather than Ctrl-C to provoke + -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know + -- why --SDM 17/12/2004 + let sig_handler ControlC = interrupt + sig_handler Break = interrupt + sig_handler _ = return () + + installHandler (Catch sig_handler) + return () +#else + return () -- nothing +#endif diff --git a/utils/ghc-pkg/Makefile b/utils/ghc-pkg/Makefile index 3f3d374..cef5a1f 100644 --- a/utils/ghc-pkg/Makefile +++ b/utils/ghc-pkg/Makefile @@ -16,6 +16,10 @@ SRC_HC_OPTS += $(PACKAGE_CABAL) # we must also build with $(GhcHcOpts) here: SRC_HC_OPTS += $(GhcHcOpts) $(GhcStage1HcOpts) +ifeq "$(Windows)" "NO" +SRC_HC_OPTS += -package unix +endif + ifeq "$(ghc_ge_607)" "YES" SRC_HC_OPTS += -package containers endif -- 1.7.10.4