-{-# 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
-#if __GLASGOW_HASKELL__ >= 609
import qualified Control.Exception as Exception
-#else
-import qualified Control.Exception.Extensible as Exception
-#endif
import Data.Maybe
import Data.Char ( isSpace, toLower )
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
#if __GLASGOW_HASKELL__ < 612
import System.Posix.Internals
-#if __GLASGOW_HASKELL__ >= 611
-import GHC.IO.Handle.FD (fdToHandle)
-#else
import GHC.Handle (fdToHandle)
#endif
-#endif
#ifdef mingw32_HOST_OS
import GHC.ConsoleHandler
import System.Posix hiding (fdToHandle)
#endif
-import IO ( isPermissionError )
-
#if defined(GLOB)
import System.Process(runInteractiveCommand)
import qualified System.Info(os)
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)
| "$topdir" `isPrefixOf` d = return ()
| "$httptopdir" `isPrefixOf` d = return ()
-- can't check these, because we don't know what $(http)topdir is
+ | isRelative d = verror ForceFiles $
+ thisfield ++ ": " ++ d ++ " is a relative path"
+ -- relative paths don't make any sense; #4134
| otherwise = do
there <- liftIO $ doesDirectoryExist d
when (not there) $
_ <- 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
`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_ = "."
oflags = rw_flags .|. o_EXCL
-#if __GLASGOW_HASKELL__ < 611
withFilePath = withCString
-#endif
findTempName x = do
fd <- withFilePath filepath $ \ f ->
-- as any exceptions etc will only be able to report the
-- fd currently
h <-
-#if __GLASGOW_HASKELL__ >= 609
fdToHandle fd
-#else
- fdToHandle (fromIntegral fd)
-#endif
`Exception.onException` c_close fd
return (filepath, h)
where
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