-{-# OPTIONS -fglasgow-exts -cpp #-}
+{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2009.
import Prelude
-#include "../../includes/ghcconfig.h"
-
import System.Console.GetOpt
import qualified Control.Exception as Exception
import Data.Maybe
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
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
"-" -> 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) $
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)
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
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
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
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"
_ <- 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
_ <- 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
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
`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
renameFile newFile targetFile
#endif
`Exception.onException` do hClose newHandle
- removeFile newFile
+ removeFileSafe newFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
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'.
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 `catch` \ e ->
+ when (not $ isDoesNotExistError e) $ ioError e