module Main (main) where
import Version ( version, targetOS, targetARCH )
+import Distribution.ModuleName hiding (main)
import Distribution.InstalledPackageInfo hiding (depends)
import Distribution.Compat.ReadP
import Distribution.ParseUtils
import System.Console.GetOpt
import Text.PrettyPrint
+#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.Environment ( getArgs, getProgName, getEnv )
import System.IO
import System.IO.Error (try)
-import Data.List ( isPrefixOf, isSuffixOf, intersperse, sortBy, nub,
- unfoldr, break, partition )
-#if __GLASGOW_HASKELL__ > 604
-import Data.List ( isInfixOf )
-#else
-import Data.List ( tails )
-#endif
+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)
-- -----------------------------------------------------------------------------
-- Do the business
-data Force = ForceAll | ForceFiles | NoForce
+data Force = NoForce | ForceFiles | ForceAll | CannotForce
+ deriving (Eq,Ord)
data PackageArg = Id PackageIdentifier | Substring String (String->Bool)
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
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.
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
in
return (flag_stack, to_modify)
- db_stack <- mapM readParseDatabase final_stack
+ db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
return (db_stack, to_modify)
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
- str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
- let packages = map convertPackageInfoIn $ read str
- Exception.evaluate packages
- `catchError` \e->
- die ("error while parsing " ++ filename ++ ": " ++ show e)
- return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
+readParseDatabase :: Maybe (PackageDBName,Bool)
+ -> PackageDBName
+ -> IO (PackageDBName,PackageDB)
+readParseDatabase mb_user_conf filename
+ -- the user database (only) is allowed to be non-existent
+ | Just (user_conf,False) <- mb_user_conf, filename == user_conf
+ = return (filename, [])
+ | otherwise
+ = do str <- readFile filename
+ let packages = map convertPackageInfoIn $ read str
+ Exception.evaluate packages
+ `catchError` \e->
+ die ("error while parsing " ++ filename ++ ": " ++ show e)
+ return (filename,packages)
-- -----------------------------------------------------------------------------
-- Registering
pkg <- parsePackageInfo expanded
putStrLn "done."
+ let unversioned_deps = filter (not . realVersion) (depends pkg)
+ unless (null unversioned_deps) $
+ die ("Unversioned dependencies found: " ++
+ unwords (map display unversioned_deps))
+
let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
-- truncate the stack for validation, because we don't allow
-- packages lower in the stack to refer to those higher up.
-> 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)
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
| otherwise = parens doc
where doc = text (display (package p))
- show_simple db_stack = do
- let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
- else display
- pkgs = map showPkg $ sortBy compPkgIdVer $
- map package (allPackagesInStack db_stack)
- when (not (null pkgs)) $
- hPutStrLn stdout $ concat $ intersperse " " pkgs
+ show_simple = simplePackageList my_flags . allPackagesInStack
+
+simplePackageList :: [Flag] -> [InstalledPackageInfo] -> IO ()
+simplePackageList my_flags pkgs = do
+ let showPkg = if FlagNamesOnly `elem` my_flags then display . pkgName
+ else display
+ strs = map showPkg $ sortBy compPkgIdVer $ map package pkgs
+ when (not (null pkgs)) $
+ hPutStrLn stdout $ concat $ intersperse " " strs
-- -----------------------------------------------------------------------------
-- Prints the highest (hidden or exposed) version of a package
-> 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)
(db_stack, _) <- getPkgDatabases True my_flags
-- check behaves like modify for the purposes of deciding which
-- databases to use, because ordering is important.
- let pkgs = allPackagesInStack db_stack
- broken_pkgs = brokenPackages pkgs
- broken_ids = map package broken_pkgs
- broken_why = [ (package p, filter (`elem` broken_ids) (depends p))
- | p <- broken_pkgs ]
- mapM_ (putStrLn . render . show_func) broken_why
- where
- show_func | FlagSimpleOutput `elem` my_flags = show_simple
- | otherwise = show_normal
- show_simple (pid,deps) =
- text (display pid) <> colon
- <+> fsep (punctuate comma (map (text . display) deps))
- show_normal (pid,deps) =
- text "package" <+> text (display pid) <+> text "has missing dependencies:"
- $$ nest 4 (fsep (punctuate comma (map (text . display) deps)))
+ let simple_output = FlagSimpleOutput `elem` my_flags
-brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
-brokenPackages pkgs = go [] pkgs
+ let pkgs = allPackagesInStack db_stack
+
+ checkPackage p = do
+ (_,es) <- runValidate $ checkPackageConfig p db_stack False True
+ if null es
+ then return []
+ else do
+ when (not simple_output) $ do
+ reportError ("There are problems in package " ++ display (package p) ++ ":")
+ reportValidateErrors es " " Nothing
+ return ()
+ return [p]
+
+ broken_pkgs <- concat `fmap` mapM checkPackage pkgs
+
+ let filterOut pkgs1 pkgs2 = filter not_in pkgs2
+ where not_in p = package p `notElem` all_ps
+ all_ps = map package pkgs1
+
+ let not_broken_pkgs = filterOut broken_pkgs pkgs
+ (_, trans_broken_pkgs) = closure [] not_broken_pkgs
+ all_broken_pkgs = broken_pkgs ++ trans_broken_pkgs
+
+ when (not (null all_broken_pkgs)) $ do
+ if simple_output
+ then simplePackageList my_flags all_broken_pkgs
+ else do
+ reportError ("\nThe following packages are broken, either because they have a problem\n"++
+ "listed above, or because they depend on a broken package.")
+ mapM_ (hPutStrLn stderr . display . package) all_broken_pkgs
+
+ when (not (null all_broken_pkgs)) $ exitWith (ExitFailure 1)
+
+
+closure :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+ -> ([InstalledPackageInfo], [InstalledPackageInfo])
+closure pkgs db_stack = go pkgs db_stack
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') -> (avail, not_avail')
+ (new_avail, not_avail') -> go (new_avail ++ avail) not_avail'
depsAvailable :: [InstalledPackageInfo] -> InstalledPackageInfo
-> Bool
-- we want mutually recursive groups of package to show up
-- as broken. (#1750)
+brokenPackages :: [InstalledPackageInfo] -> [InstalledPackageInfo]
+brokenPackages pkgs = snd (closure [] pkgs)
+
-- -----------------------------------------------------------------------------
-- Manipulating package.conf files
-- Sanity-check a new package config, and automatically build GHCi libs
-- if requested.
+type ValidateError = (Force,String)
+
+newtype Validate a = V { runValidate :: IO (a, [ValidateError]) }
+
+instance Monad Validate where
+ return a = V $ return (a, [])
+ m >>= k = V $ do
+ (a, es) <- runValidate m
+ (b, es') <- runValidate (k a)
+ return (b,es++es')
+
+verror :: Force -> String -> Validate ()
+verror f s = V (return ((),[(f,s)]))
+
+liftIO :: IO a -> Validate a
+liftIO k = V (k >>= \a -> return (a,[]))
+
+-- returns False if we should die
+reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool
+reportValidateErrors es prefix mb_force = do
+ oks <- mapM report es
+ return (and oks)
+ where
+ report (f,s)
+ | Just force <- mb_force
+ = if (force >= f)
+ then do reportError (prefix ++ s ++ " (ignoring)")
+ return True
+ else if f < CannotForce
+ then do reportError (prefix ++ s ++ " (use --force to override)")
+ return False
+ else do reportError err
+ return False
+ | otherwise = do reportError err
+ return False
+ where
+ err = prefix ++ s
+
validatePackageConfig :: InstalledPackageInfo
-> PackageDBStack
-> Bool -- auto-ghc-libs
- -> Bool -- update
+ -> Bool -- update, or check
-> Force
-> IO ()
validatePackageConfig pkg db_stack auto_ghci_libs update force = do
+ (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update
+ ok <- reportValidateErrors es (display (package pkg) ++ ": ") (Just force)
+ when (not ok) $ exitWith (ExitFailure 1)
+
+checkPackageConfig :: InstalledPackageInfo
+ -> PackageDBStack
+ -> Bool -- auto-ghc-libs
+ -> Bool -- update, or check
+ -> Validate ()
+checkPackageConfig pkg db_stack auto_ghci_libs update = do
checkPackageId pkg
- checkDuplicates db_stack pkg update force
- mapM_ (checkDep db_stack force) (depends pkg)
- mapM_ (checkDir force) (importDirs pkg)
- mapM_ (checkDir force) (libraryDirs pkg)
- mapM_ (checkDir force) (includeDirs pkg)
- mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs force) (hsLibraries pkg)
+ checkDuplicates db_stack pkg update
+ mapM_ (checkDep db_stack) (depends pkg)
+ checkDuplicateDepends (depends pkg)
+ mapM_ (checkDir "import-dirs") (importDirs pkg)
+ mapM_ (checkDir "library-dirs") (libraryDirs pkg)
+ mapM_ (checkDir "include-dirs") (includeDirs pkg)
+ checkModules pkg
+ mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg)
-- ToDo: check these somehow?
-- extra_libraries :: [String],
-- c_includes :: [String],
-- end up with a package id that cannot be parsed. This will lead to
-- difficulties when the user wants to refer to the package later, so
-- we check that the package id can be parsed properly here.
-checkPackageId :: InstalledPackageInfo -> IO ()
+checkPackageId :: InstalledPackageInfo -> Validate ()
checkPackageId ipi =
let str = display (package ipi) in
case [ x :: PackageIdentifier | (x,ys) <- readP_to_S parse str, all isSpace ys ] of
[_] -> return ()
- [] -> die ("invalid package identifier: " ++ str)
- _ -> die ("ambiguous package identifier: " ++ str)
+ [] -> verror CannotForce ("invalid package identifier: " ++ str)
+ _ -> verror CannotForce ("ambiguous package identifier: " ++ str)
-checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Force -> IO ()
-checkDuplicates db_stack pkg update force = do
+checkDuplicates :: PackageDBStack -> InstalledPackageInfo -> Bool -> Validate ()
+checkDuplicates db_stack pkg update = do
let
pkgid = package pkg
(_top_db_name, pkgs) : _ = db_stack
-- Check whether this package id already exists in this DB
--
when (not update && (pkgid `elem` map package pkgs)) $
- die ("package " ++ display pkgid ++ " is already installed")
+ verror CannotForce $
+ "package " ++ display pkgid ++ " is already installed"
let
uncasep = map toLower . display
dups = filter ((== uncasep pkgid) . uncasep) (map package pkgs)
- when (not update && not (null dups)) $ dieOrForceAll force $
+ when (not update && not (null dups)) $ verror ForceAll $
"Package names may be treated case-insensitively in the future.\n"++
"Package " ++ display pkgid ++
" overlaps with: " ++ unwords (map display dups)
-checkDir :: Force -> String -> IO ()
-checkDir force d
+checkDir :: String -> String -> Validate ()
+checkDir thisfield d
| "$topdir" `isPrefixOf` d = return ()
| "$httptopdir" `isPrefixOf` d = return ()
-- can't check these, because we don't know what $(http)topdir is
| otherwise = do
- there <- doesDirectoryExist d
- when (not there)
- (dieOrForceFile force (d ++ " doesn't exist or isn't a directory"))
+ there <- liftIO $ doesDirectoryExist d
+ when (not there) $
+ verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory")
-checkDep :: PackageDBStack -> Force -> PackageIdentifier -> IO ()
-checkDep db_stack force pkgid
+checkDep :: PackageDBStack -> PackageIdentifier -> Validate ()
+checkDep db_stack pkgid
| pkgid `elem` pkgids || (not real_version && name_exists) = return ()
- | otherwise = dieOrForceAll force ("dependency " ++ display pkgid
- ++ " doesn't exist")
+ | otherwise = verror ForceAll ("dependency " ++ display pkgid
+ ++ " doesn't exist")
where
-- for backwards compat, we treat 0.0 as a special version,
-- and don't check that it actually exists.
all_pkgs = allPackagesInStack db_stack
pkgids = map package all_pkgs
+checkDuplicateDepends :: [PackageIdentifier] -> Validate ()
+checkDuplicateDepends deps
+ | null dups = return ()
+ | otherwise = verror ForceAll ("package has duplicate dependencies: " ++
+ unwords (map display dups))
+ where
+ dups = [ p | (p:_:_) <- group (sort deps) ]
+
realVersion :: PackageIdentifier -> Bool
realVersion pkgid = versionBranch (pkgVersion pkgid) /= []
-checkHSLib :: [String] -> Bool -> Force -> String -> IO ()
-checkHSLib dirs auto_ghci_libs force lib = do
+checkHSLib :: [String] -> Bool -> String -> Validate ()
+checkHSLib dirs auto_ghci_libs lib = do
let batch_lib_file = "lib" ++ lib ++ ".a"
- bs <- mapM (doesLibExistIn batch_lib_file) dirs
- case [ dir | (exists,dir) <- zip bs dirs, exists ] of
- [] -> dieOrForceFile force ("cannot find " ++ batch_lib_file ++
- " on library path")
- (dir:_) -> checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs
-
-doesLibExistIn :: String -> String -> IO Bool
-doesLibExistIn lib d
+ m <- liftIO $ doesFileExistOnPath batch_lib_file dirs
+ 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
+
+doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath)
+doesFileExistOnPath file path = go path
+ where go [] = return Nothing
+ go (p:ps) = do b <- doesFileExistIn file p
+ if b then return (Just p) else go ps
+
+doesFileExistIn :: String -> String -> IO Bool
+doesFileExistIn lib d
| "$topdir" `isPrefixOf` d = return True
| "$httptopdir" `isPrefixOf` d = return True
- | otherwise = doesFileExist (d ++ '/':lib)
+ | otherwise = doesFileExist (d </> lib)
+
+checkModules :: InstalledPackageInfo -> Validate ()
+checkModules pkg = do
+ mapM_ findModule (exposedModules pkg ++ hiddenModules pkg)
+ where
+ findModule modl = do
+ -- there's no .hi file for GHC.Prim
+ if modl == fromString "GHC.Prim" then return () else do
+ let file = toFilePath modl <.> "hi"
+ m <- liftIO $ doesFileExistOnPath file (importDirs pkg)
+ 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
| auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file
| otherwise = do
- bs <- mapM (doesLibExistIn ghci_lib_file) dirs
- case [dir | (exists,dir) <- zip bs dirs, exists] of
- [] -> hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
- (_:_) -> return ()
- where
- ghci_lib_file = lib ++ ".o"
+ m <- doesFileExistOnPath ghci_lib_file dirs
+ when (isNothing m) $
+ hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file)
+ where
+ ghci_lib_file = lib <.> "o"
-- automatically build the GHCi version of a batch lib,
-- using ld --whole-archive.
dieOrForceAll ForceAll s = ignoreError s
dieOrForceAll _other s = dieForcible s
-dieOrForceFile :: Force -> String -> IO ()
-dieOrForceFile ForceAll s = ignoreError s
-dieOrForceFile ForceFiles s = ignoreError s
-dieOrForceFile _other s = dieForcible s
-
ignoreError :: String -> IO ()
-ignoreError s = do hFlush stdout; hPutStrLn stderr (s ++ " (ignoring)")
+ignoreError s = reportError (s ++ " (ignoring)")
+
+reportError :: String -> IO ()
+reportError s = do hFlush stdout; hPutStrLn stderr s
dieForcible :: String -> IO ()
dieForcible s = die (s ++ " (use --force to override)")
installSignalHandlers = do
threadid <- myThreadId
let
- interrupt = throwTo threadid (Exception.ErrorCall "interrupted")
+ interrupt = Exception.throwTo threadid
+ (Exception.ErrorCall "interrupted")
--
#if !defined(mingw32_HOST_OS)
- installHandler sigQUIT (Catch interrupt) Nothing
+ installHandler sigQUIT (Catch interrupt) Nothing
installHandler sigINT (Catch interrupt) Nothing
return ()
#elif __GLASGOW_HASKELL__ >= 603
isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
#endif
-catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-catchIO = Exception.catch
-#else
-catchIO io handler = io `Exception.catch` handler'
- where handler' (Exception.IOException ioe) = handler ioe
- 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)
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+catchIO = Exception.catch
#endif
catchError :: IO a -> (String -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
catchError io handler = io `Exception.catch` handler'
where handler' (Exception.ErrorCall err) = handler err
-#else
-catchError io handler = io `Exception.catch` handler'
- where handler' (Exception.ErrorCall err) = handler err
- handler' e = Exception.throw e
-#endif
-
-onException :: IO a -> IO () -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
- Exception.throw e
-#endif
-- copied from Cabal's Distribution.Simple.Utils, except that we want
-- 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
+ `Exception.onException` do hClose newHandle
+ removeFile newFile
where
template = targetName <.> "tmp"
targetDir | null targetDir_ = "."
--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
+ `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
+
+-- | 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