module Distribution.Compat.TempFile (openTempFile, openBinaryTempFile,
openNewBinaryFile) where
#if __NHC__ || __HUGS__
import System.IO (openFile, openBinaryFile,
Handle, IOMode(ReadWriteMode))
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>), splitExtension)
#if __NHC__
import System.Posix.Types (CPid(..))
foreign import ccall unsafe "getpid" c_getpid :: IO CPid
#else
import System.Posix.Internals (c_getpid)
#endif
#else
import System.IO
import Data.Bits
import System.Posix.Internals
import Foreign.C
import GHC.Handle
import Distribution.Compat.Exception
#endif
#if __NHC__ || __HUGS__
openTempFile :: FilePath -> String -> IO (FilePath, Handle)
openTempFile tmp_dir template
= do x <- getProcessID
findTempName x
where
(templateBase, templateExt) = splitExtension template
findTempName :: Int -> IO (FilePath, Handle)
findTempName x
= do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
b <- doesFileExist path
if b then findTempName (x+1)
else do hnd <- openFile path ReadWriteMode
return (path, hnd)
openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
openBinaryTempFile tmp_dir template
= do x <- getProcessID
findTempName x
where
(templateBase, templateExt) = splitExtension template
findTempName :: Int -> IO (FilePath, Handle)
findTempName x
= do let path = tmp_dir </> (templateBase ++ show x) <.> templateExt
b <- doesFileExist path
if b then findTempName (x+1)
else do hnd <- openBinaryFile path ReadWriteMode
return (path, hnd)
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile = openBinaryTempFile
getProcessID :: IO Int
getProcessID = fmap fromIntegral c_getpid
#else
openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)
openNewBinaryFile dir template = do
pid <- c_getpid
findTempName pid
where
(prefix,suffix) =
case break (== '.') $ reverse template of
(rev_suffix, "") -> (reverse rev_suffix, "")
(rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix)
_ -> error "bug in System.IO.openTempFile"
oflags = rw_flags .|. o_EXCL .|. o_BINARY
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
h <-
#if __GLASGOW_HASKELL__ >= 609
fdToHandle fd
#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)
openFd (fromIntegral fd) Nothing False filepath
ReadWriteMode True
#else
fdToHandle (fromIntegral fd)
#endif
`onException` c_close fd
return (filepath, h)
where
filename = prefix ++ show x ++ suffix
filepath = dir `combine` filename
combine a b
| null b = a
| null a = b
| last a == pathSeparator = a ++ b
| otherwise = a ++ [pathSeparator] ++ b
pathSeparator :: Char
#ifdef mingw32_HOST_OS
pathSeparator = '\\'
#else
pathSeparator = '/'
#endif
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