X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=1db09ff8a377a3287be7624165f09513f315d268;hb=e9e2a5412bb7cda8d13a063ac403d9f18ac97380;hp=63117a293bb26ec0a5d247b4efecb6bb695a9fc5;hpb=8449ae9350867e2f18cb70f765fdea842ce61542;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index 63117a2..1db09ff 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} #undef DEBUG_DUMP #undef DEBUG @@ -27,14 +27,14 @@ module GHC.Handle ( readRawBuffer, readRawBufferPtr, writeRawBuffer, writeRawBufferPtr, -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS unlockFile, #endif ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, openFd, fdToHandle, + IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle, hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, hFlush, hDuplicate, hDuplicateTo, @@ -54,8 +54,7 @@ module GHC.Handle ( ) where -#include "ghcconfig.h" - +import System.Directory.Internals import Control.Monad import Data.Bits import Data.Maybe @@ -373,7 +372,7 @@ newEmptyBuffer b state size allocateBuffer :: Int -> BufferState -> IO Buffer allocateBuffer sz@(I# size) state = IO $ \s -> -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS -- To implement asynchronous I/O under Win32, we have to pass -- buffer references to external threads that handles the -- filling/emptying of their contents. Hence, the buffer cannot @@ -524,7 +523,7 @@ fillReadBufferWithoutBlocking fd is_stream -- Low level routines for reading/writing to (raw)buffers: -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt readRawBuffer loc fd is_stream buf off len = throwErrnoIfMinus1RetryMayBlock loc @@ -567,7 +566,7 @@ foreign import ccall unsafe "__hscore_PrelHandle_write" foreign import ccall unsafe "__hscore_PrelHandle_write" write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt -#else /* mingw32_TARGET_OS.... */ +#else /* mingw32_HOST_OS.... */ readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt readRawBuffer loc fd is_stream buf off len @@ -785,9 +784,13 @@ openFile' filepath mode binary = let oflags1 = case mode of - ReadMode -> read_flags - WriteMode -> write_flags - ReadWriteMode -> rw_flags + ReadMode -> read_flags +#ifdef mingw32_HOST_OS + WriteMode -> write_flags .|. o_TRUNC +#else + WriteMode -> write_flags +#endif + ReadWriteMode -> rw_flags AppendMode -> append_flags binary_flags @@ -806,19 +809,72 @@ openFile' filepath mode binary = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - openFd fd Nothing False filepath mode binary - `catchException` \e -> do c_close (fromIntegral fd); throw e + h <- openFd fd Nothing False filepath mode binary + `catchException` \e -> do c_close (fromIntegral fd); throw e -- NB. don't forget to close the FD if openFd fails, otherwise -- this FD leaks. -- ASSERT: if we just created the file, then openFd won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). +#ifndef mingw32_HOST_OS + if mode == WriteMode + then throwErrnoIf (/=0) "openFile" + (c_ftruncate (fromIntegral fd) 0) + else return 0 +#endif + return h + + +-- | The function creates a temporary file in ReadWrite mode. +-- The created file isn\'t deleted automatically, so you need to delete it manually. +openTempFile :: FilePath -- ^ Directory in which to create the file + -> String -- ^ File name template. If the template is \"foo.ext\" then + -- the create file will be \"fooXXX.ext\" where XXX is some + -- random number. + -> IO (FilePath, Handle) +openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE + +-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True + +openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle) +openTempFile' loc tmp_dir template binary = do + pid <- c_getpid + findTempName pid + where + (prefix,suffix) = break (=='.') template + + oflags1 = rw_flags .|. o_EXCL + + binary_flags + | binary = o_BINARY + | otherwise = 0 + + oflags = oflags1 .|. binary_flags + + 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 loc errno Nothing (Just tmp_dir)) + else do + h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True + `catchException` \e -> do c_close (fromIntegral fd); throw e + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = tmp_dir `joinFileName` filename std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY .|. o_TRUNC +write_flags = output_flags .|. o_WRONLY rw_flags = output_flags .|. o_RDWR append_flags = write_flags .|. o_APPEND @@ -855,7 +911,7 @@ openFd fd mb_fd_type is_socket filepath mode binary = do -- regular files need to be locked RegularFile -> do -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" @@ -871,7 +927,7 @@ fdToHandle fd = do openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt @@ -981,13 +1037,11 @@ hClose_handle_ handle_ = do c_fd = fromIntegral fd -- close the file descriptor, but not when this is the read - -- side of a duplex handle, and not when this is one of the - -- std file handles. + -- side of a duplex handle. case haOtherSide handle_ of Nothing -> - when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $ throwErrnoIfMinus1Retry_ "hClose" -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS (closeFd (haIsStream handle_) c_fd) #else (c_close c_fd) @@ -997,7 +1051,7 @@ hClose_handle_ handle_ = do -- free the spare buffers writeIORef (haBuffers handle_) BufferListNil -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS -- unlock it unlockFile c_fd #endif @@ -1149,7 +1203,7 @@ hSetBuffering handle mode = is_tty <- fdIsTTY (haFD handle_) when (is_tty && isReadableHandleType (haType handle_)) $ case mode of -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS -- 'raw' mode under win32 is a bit too specialised (and troublesome -- for most common uses), so simply disable its use here. NoBuffering -> setCooked (haFD handle_) False @@ -1302,7 +1356,7 @@ hTell :: Handle -> IO Integer hTell handle = wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_OS) -- urgh, on Windows we have to worry about \n -> \r\n translation, -- so we can't easily calculate the file position using the -- current buffer size. Just flush instead.