X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=344a21edb89cd5278db8146a3496b270e5b1acfe;hb=e5e6f6a16796cba5e2b6bd376481cf2cd0ba9734;hp=d7431939f17f14353273b58d03d6472331aedd79;hpb=082089d195345e5c367df82b599e2c0848fb9d0b;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index d743193..344a21e 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -46,15 +46,17 @@ import System.IO.Error (try) import Data.List import Control.Concurrent -#ifdef mingw32_HOST_OS import Foreign -import Foreign.C.String +import Foreign.C +#ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else -import System.Posix +import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError, isDoesNotExistError ) +import IO ( isPermissionError ) +import System.Posix.Internals +import GHC.Handle (fdToHandle) #if defined(GLOB) import System.Process(runInteractiveCommand) @@ -409,7 +411,7 @@ getPkgDatabases modify my_flags = do user_conf = dir subdir "package.conf" user_exists <- doesFileExist user_conf return (Just (user_conf,user_exists)) - Left ex -> + Left _ -> return Nothing -- If the user database doesn't exist, and this command isn't a @@ -426,7 +428,7 @@ getPkgDatabases modify my_flags = do Right path | last cs == "" -> init cs ++ sys_databases | otherwise -> cs - where cs = splitSearchPath path + where cs = parseSearchPath path -- The "global" database is always the one at the bottom of the stack. -- This is the database we modify by default. @@ -434,7 +436,7 @@ getPkgDatabases modify my_flags = do let db_flags = [ f | Just f <- map is_db_flag my_flags ] where is_db_flag FlagUser - | Just (user_conf,user_exists) <- mb_user_conf + | Just (user_conf, _user_exists) <- mb_user_conf = Just user_conf is_db_flag FlagGlobal = Just virt_global_conf is_db_flag (FlagConfig f) = Just f @@ -550,7 +552,7 @@ modifyPackage -> Force -> IO () modifyPackage fn pkgid my_flags force = do - (db_stack, Just to_modify) <- getPkgDatabases True{-modify-} my_flags + (db_stack, Just _to_modify) <- getPkgDatabases True{-modify-} my_flags ((db_name, pkgs), ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) -- let ((db_name, pkgs) : rest_of_stack) = db_stack -- ps <- findPackages [(db_name,pkgs)] (Id pkgid) @@ -563,7 +565,8 @@ modifyPackage fn pkgid my_flags force = do let old_broken = brokenPackages (allPackagesInStack db_stack) - rest_of_stack = [ (nm,pkgs) | (nm,pkgs) <- db_stack, nm /= db_name ] + rest_of_stack = [ (nm, mypkgs) + | (nm, mypkgs) <- db_stack, nm /= db_name ] new_stack = (db_name,new_config) : rest_of_stack new_broken = map package (brokenPackages (allPackagesInStack new_stack)) newly_broken = filter (`notElem` map package old_broken) new_broken @@ -666,7 +669,7 @@ findPackagesByDB :: PackageDBStack -> PackageArg -> IO [(NamedPackageDB, [InstalledPackageInfo])] findPackagesByDB db_stack pkgarg = case [ (db, matched) - | db@(db_name,pkgs) <- db_stack, + | db@(_, pkgs) <- db_stack, let matched = filter (pkgarg `matchesPkg`) pkgs, not (null matched) ] of [] -> die ("cannot find package " ++ pkg_msg pkgarg) @@ -783,8 +786,8 @@ brokenPackages pkgs = go [] pkgs where go avail not_avail = case partition (depsAvailable avail) not_avail of - ([], not_avail) -> not_avail - (new_avail, not_avail) -> go (new_avail ++ avail) not_avail + ([], not_avail') -> not_avail' + (new_avail, not_avail') -> go (new_avail ++ avail) not_avail' depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo -> Bool @@ -1141,12 +1144,14 @@ catchIO io handler = io `Exception.catch` handler' handler' e = Exception.throw e #endif +#if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a #if __GLASGOW_HASKELL__ >= 609 throwIOIO = Exception.throwIO #else throwIOIO ioe = Exception.throwIO (Exception.IOException ioe) #endif +#endif catchError :: IO a -> (String -> IO a) -> IO a #if __GLASGOW_HASKELL__ >= 609 @@ -1158,7 +1163,7 @@ catchError io handler = io `Exception.catch` handler' handler' e = Exception.throw e #endif -onException :: IO a -> IO () -> IO a +onException :: IO a -> IO b -> IO a #if __GLASGOW_HASKELL__ >= 609 onException = Exception.onException #else @@ -1171,26 +1176,26 @@ onException io what = io `Exception.catch` \e -> do what -- to use text files here, rather than binary files. writeFileAtomic :: FilePath -> String -> IO () writeFileAtomic targetFile content = do - (tmpFile, tmpHandle) <- openTempFile targetDir template - do hPutStr tmpHandle content - hClose tmpHandle + (newFile, newHandle) <- openNewFile targetDir template + do hPutStr newHandle content + hClose newHandle #if mingw32_HOST_OS || mingw32_TARGET_OS - renameFile tmpFile targetFile + renameFile newFile targetFile -- If the targetFile exists then renameFile will fail `catchIO` \err -> do exists <- doesFileExist targetFile if exists then do removeFile targetFile -- Big fat hairy race condition - renameFile tmpFile targetFile + renameFile newFile targetFile -- If the removeFile succeeds and the renameFile fails -- then we've lost the atomic property. else throwIOIO err #else - renameFile tmpFile targetFile + renameFile newFile targetFile #endif - `onException` do hClose tmpHandle - removeFile tmpFile + `onException` do hClose newHandle + removeFile newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1198,3 +1203,80 @@ writeFileAtomic targetFile content = do --TODO: remove this when takeDirectory/splitFileName is fixed -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile + +-- Ugh, this is a copy/paste of code from the base library, but +-- if uses 666 rather than 600 for the permissions. +openNewFile :: FilePath -> String -> IO (FilePath, Handle) +openNewFile dir template = do + 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 + + findTempName x = do + fd <- withCString 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 <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#else + fdToHandle (fromIntegral fd) +#endif + `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 + +-- | The function splits the given string to substrings +-- using 'isSearchPathSeparator'. +parseSearchPath :: String -> [FilePath] +parseSearchPath path = split path + where + split :: String -> [String] + split s = + case rest' of + [] -> [chunk] + _:rest -> chunk : split rest + where + chunk = + case chunk' of +#ifdef mingw32_HOST_OS + ('\"':xs@(_:_)) | last xs == '\"' -> init xs +#endif + _ -> chunk' + + (chunk', rest') = break isSearchPathSeparator s