X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=e843d88a38846a878feffe78af3e9a40bfc27aab;hp=e5398ad33d647a8c32c73b75dc6138dc80508e1a;hb=b00e3a6c0a82a8af3238d677f798d812cd7fd49f;hpb=1d9983e852b11a16b77d549b8acb6ba4abdf6601 diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index e5398ad..e843d88 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2004-2009. @@ -27,8 +27,6 @@ import Text.Printf import Prelude -#include "../../includes/ghcconfig.h" - import System.Console.GetOpt import qualified Control.Exception as Exception import Data.Maybe @@ -40,7 +38,7 @@ import System.Directory ( doesDirectoryExist, getDirectoryContents, import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO -import System.IO.Error (try) +import System.IO.Error import Data.List import Control.Concurrent @@ -48,31 +46,24 @@ import qualified Data.ByteString.Lazy as B import qualified Data.Binary as Bin import qualified Data.Binary.Get as Bin -#if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile import Foreign import Foreign.C #endif -#if __GLASGOW_HASKELL__ < 612 -import System.Posix.Internals -import GHC.Handle (fdToHandle) -#endif - #ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError ) - #if defined(GLOB) import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif -#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING) +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) import System.Console.Terminfo as Terminfo #endif @@ -649,10 +640,8 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do "-" -> do when (verbosity >= Normal) $ putStr "Reading package info from stdin ... " -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdin utf8 -#endif getContents f -> do when (verbosity >= Normal) $ @@ -721,7 +710,7 @@ changeDBDir verbosity cmds db = do do_cmd (RemovePackage p) = do let file = location db display (installedPackageId p) <.> "conf" when (verbosity > Normal) $ putStrLn ("removing " ++ file) - removeFile file + removeFileSafe file do_cmd (AddPackage p) = do let file = location db display (installedPackageId p) <.> "conf" when (verbosity > Normal) $ putStrLn ("writing " ++ file) @@ -735,7 +724,7 @@ updateDBCache verbosity db = do when (verbosity > Normal) $ putStrLn ("writing cache " ++ filename) writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) - `catch` \e -> + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e @@ -856,7 +845,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do if simple_output then show_simple stack else do -#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING) +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) mapM_ show_normal stack #else let @@ -946,10 +935,8 @@ dumpPackages verbosity my_flags = do doDump :: [InstalledPackageInfo] -> IO () doDump pkgs = do -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdout utf8 -#endif mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs -- PackageId is can have globVersion for the version @@ -1151,7 +1138,7 @@ writeNewConfig verbosity filename ipis = do $ map (show . convertPackageInfoOut) ipis fileContents = "[" ++ shown ++ "\n]" writeFileUtf8Atomic filename fileContents - `catch` \e -> + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e @@ -1324,7 +1311,7 @@ checkHSLib dirs auto_ghci_libs lib = do case m of Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ " on library path") - Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) doesFileExistOnPath file path = go path @@ -1350,13 +1337,10 @@ checkModules pkg = do when (isNothing m) $ verror ForceFiles ("file " ++ file ++ " is missing") -checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () -checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build +checkGHCiLib :: String -> String -> String -> Bool -> IO () +checkGHCiLib batch_lib_dir batch_lib_file lib auto_build | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = do - m <- doesFileExistOnPath ghci_lib_file dirs - when (isNothing m && ghci_lib_file /= "HSrts.o") $ - warn ("warning: can't find GHCi lib " ++ ghci_lib_file) + | otherwise = return () where ghci_lib_file = lib <.> "o" @@ -1390,7 +1374,7 @@ findModules paths = return (concat mms) searchDir path prefix = do - fs <- getDirectoryEntries path `catch` \_ -> return [] + fs <- getDirectoryEntries path `catchIO` \_ -> return [] searchEntries path prefix fs searchEntries path prefix [] = return [] @@ -1433,7 +1417,7 @@ expandEnvVars str0 force = go str0 "" lookupEnvVar :: String -> IO String lookupEnvVar nm = - catch (System.Environment.getEnv nm) + catchIO (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -1532,7 +1516,7 @@ installSignalHandlers = do _ <- installHandler sigQUIT (Catch interrupt) Nothing _ <- installHandler sigINT (Catch interrupt) Nothing return () -#elif __GLASGOW_HASKELL__ >= 603 +#else -- 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 @@ -1544,22 +1528,15 @@ installSignalHandlers = do _ <- installHandler (Catch sig_handler) return () -#else - return () -- nothing -#endif - -#if __GLASGOW_HASKELL__ <= 604 -isInfixOf :: (Eq a) => [a] -> [a] -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) #endif #if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a throwIOIO = Exception.throwIO +#endif catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = Exception.catch -#endif catchError :: IO a -> (String -> IO a) -> IO a catchError io handler = io `Exception.catch` handler' @@ -1575,9 +1552,7 @@ writeBinaryFileAtomic targetFile obj = writeFileUtf8Atomic :: FilePath -> String -> IO () writeFileUtf8Atomic targetFile content = withFileAtomic targetFile $ \h -> do -#if __GLASGOW_HASKELL__ >= 612 hSetEncoding h utf8 -#endif hPutStr h content -- copied from Cabal's Distribution.Simple.Utils, except that we want @@ -1593,7 +1568,7 @@ withFileAtomic targetFile write_content = do `catchIO` \err -> do exists <- doesFileExist targetFile if exists - then do removeFile targetFile + then do removeFileSafe targetFile -- Big fat hairy race condition renameFile newFile targetFile -- If the removeFile succeeds and the renameFile fails @@ -1603,7 +1578,7 @@ withFileAtomic targetFile write_content = do renameFile newFile targetFile #endif `Exception.onException` do hClose newHandle - removeFile newFile + removeFileSafe newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1614,67 +1589,10 @@ withFileAtomic targetFile write_content = do openNewFile :: FilePath -> String -> IO (FilePath, Handle) openNewFile dir template = do -#if __GLASGOW_HASKELL__ >= 612 -- this was added to System.IO in 6.12.1 -- we must use this version because the version below opens the file -- in binary mode. openTempFileWithDefaultPermissions dir template -#else - -- Ugh, this is a copy/paste of code from the base library, but - -- if uses 666 rather than 600 for the permissions. - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL - -#if __GLASGOW_HASKELL__ < 611 - withFilePath = withCString -#endif - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- - fdToHandle fd - `Exception.onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - --- XXX Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR -#endif /* GLASGOW_HASKELL < 612 */ -- | The function splits the given string to substrings -- using 'isSearchPathSeparator'. @@ -1699,8 +1617,12 @@ parseSearchPath path = split path readUTF8File :: FilePath -> IO String readUTF8File file = do h <- openFile file ReadMode -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8 hSetEncoding h utf8 -#endif hGetContents h + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: FilePath -> IO () +removeFileSafe fn = + removeFile fn `catchIO` \ e -> + when (not $ isDoesNotExistError e) $ ioError e