-{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
#undef DEBUG_DUMP
#undef DEBUG
--
-----------------------------------------------------------------------------
+-- #hide
module GHC.Handle (
withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
fillReadBuffer, fillReadBufferWithoutBlocking,
readRawBuffer, readRawBufferPtr,
writeRawBuffer, writeRawBufferPtr,
+
+#ifndef mingw32_HOST_OS
unlockFile,
-
+#endif
+
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
- IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
- hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle,
+ hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
) where
-#include "config.h"
-
import Control.Monad
import Data.Bits
import Data.Maybe
import GHC.Num ( Integer(..), Num(..) )
import GHC.Show
import GHC.Real ( toInteger )
+#if defined(DEBUG_DUMP)
+import GHC.Pack
+#endif
import GHC.Conc
withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
+withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
withHandle_' fun h m act =
block $ do
h_ <- takeMVar m
"seek operations on text-mode handles are not allowed on this platform"
Nothing)
+ioe_finalizedHandle fp = throw (IOException
+ (IOError Nothing IllegalOperation ""
+ "handle is finalized" (Just fp)))
+
ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
(IOError Nothing InvalidArgument "hSetBuffering"
-- The finalizer is then placed on the write side, and the handle only gets
-- finalized once, when both sides are no longer required.
-stdHandleFinalizer :: MVar Handle__ -> IO ()
-stdHandleFinalizer m = do
+-- NOTE about finalized handles: It's possible that a handle can be
+-- finalized and then we try to use it later, for example if the
+-- handle is referenced from another finalizer, or from a thread that
+-- has become unreferenced and then resurrected (arguably in the
+-- latter case we shouldn't finalize the Handle...). Anyway,
+-- we try to emit a helpful message which is better than nothing.
+
+stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+stdHandleFinalizer fp m = do
h_ <- takeMVar m
flushWriteBufferOnly h_
+ putMVar m (ioe_finalizedHandle fp)
-handleFinalizer :: MVar Handle__ -> IO ()
-handleFinalizer m = do
+handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+handleFinalizer fp m = do
handle_ <- takeMVar m
case haType handle_ of
ClosedHandle -> return ()
-- descriptor anyway...
hClose_handle_ handle_
return ()
+ putMVar m (ioe_finalizedHandle fp)
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
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
puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
# endif
throwErrnoIfMinus1Retry "flushReadBuffer"
- (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
+ (c_lseek fd (fromIntegral off) sEEK_CUR)
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
if bytes == 0
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
- res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
+ res <- writeRawBuffer "flushWriteBuffer" fd is_stream b
(fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
-- buffer better be empty:
assert (r == 0 && w == 0) $ do
#ifdef DEBUG_DUMP
- puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
+ puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
#endif
res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
0 (fromIntegral size)
-- Low level routines for reading/writing to (raw)buffers:
-#ifndef mingw32_TARGET_OS
-readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBuffer loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (read_rawBuffer fd buf off len)
- (threadWaitRead fd)
+#ifndef mingw32_HOST_OS
-readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryOnBlock loc
- (read_rawBuffer fd buf off len)
- (return 0)
+{-
+NOTE [nonblock]:
+
+Unix has broken semantics when it comes to non-blocking I/O: you can
+set the O_NONBLOCK flag on an FD, but it applies to the all other FDs
+attached to the same underlying file, pipe or TTY; there's no way to
+have private non-blocking behaviour for an FD. See bug #724.
+
+We fix this by only setting O_NONBLOCK on FDs that we create; FDs that
+come from external sources or are exposed externally are left in
+blocking mode. This solution has some problems though. We can't
+completely simulate a non-blocking read without O_NONBLOCK: several
+cases are wrong here. The cases that are wrong:
+
+ * reading/writing to a blocking FD in non-threaded mode.
+ In threaded mode, we just make a safe call to read().
+ In non-threaded mode we call select() before attempting to read,
+ but that leaves a small race window where the data can be read
+ from the file descriptor before we issue our blocking read().
+ * readRawBufferNoBlock for a blocking FD
+-}
+
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read
+ | threaded = safe_read
+ | otherwise = do r <- throwErrnoIfMinus1 loc
+ (fdReady (fromIntegral fd) 0 0 False)
+ if r /= 0
+ then unsafe_read
+ else do threadWaitRead (fromIntegral fd); unsafe_read
+ where
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitRead (fromIntegral fd))
+ unsafe_read = do_read (read_rawBuffer fd buf off len)
+ safe_read = do_read (safe_read_rawBuffer fd buf off len)
readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-readRawBufferPtr loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (read_off fd buf off len)
- (threadWaitRead fd)
+readRawBufferPtr loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read
+ | threaded = safe_read
+ | otherwise = do r <- throwErrnoIfMinus1 loc
+ (fdReady (fromIntegral fd) 0 0 False)
+ if r /= 0
+ then unsafe_read
+ else do threadWaitRead (fromIntegral fd); unsafe_read
+ where
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitRead (fromIntegral fd))
+ unsafe_read = do_read (read_off fd buf off len)
+ safe_read = do_read (safe_read_off fd buf off len)
+
+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBufferNoBlock loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_read
+ | otherwise = do r <- fdReady (fromIntegral fd) 0 0 False
+ if r /= 0 then safe_read
+ else return 0
+ -- XXX see note [nonblock]
+ where
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call (return 0)
+ unsafe_read = do_read (read_rawBuffer fd buf off len)
+ safe_read = do_read (safe_read_rawBuffer fd buf off len)
writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-writeRawBuffer loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (write_rawBuffer (fromIntegral fd) buf off len)
- (threadWaitWrite fd)
+writeRawBuffer loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_write
+ | threaded = safe_write
+ | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False
+ if r /= 0 then safe_write
+ else return 0
+ where
+ do_write call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitWrite (fromIntegral fd))
+ unsafe_write = do_write (write_rawBuffer fd buf off len)
+ safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-writeRawBufferPtr loc fd is_stream buf off len =
- throwErrnoIfMinus1RetryMayBlock loc
- (write_off (fromIntegral fd) buf off len)
- (threadWaitWrite fd)
+writeRawBufferPtr loc fd is_nonblock buf off len
+ | is_nonblock = unsafe_write
+ | threaded = safe_write
+ | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False
+ if r /= 0 then safe_write
+ else return 0
+ where
+ do_write call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitWrite (fromIntegral fd))
+ unsafe_write = do_write (write_off fd buf off len)
+ safe_write = do_write (safe_write_off (fromIntegral fd) buf off len)
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+ read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+ read_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_write"
write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_write"
write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-#else /* mingw32_TARGET_OS.... */
+foreign import ccall safe "fdReady"
+ fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
+
+#else /* mingw32_HOST_OS.... */
readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_stream buf off len
-- ToDo: we don't have a non-blocking primitve read on Win32
readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-readRawBufferNoBlock = readRawBufferNoBlock
+readRawBufferNoBlock = readRawBuffer
-- Async versions of the read/write primitives, for the non-threaded RTS
asyncReadRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0)
+ (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) off buf
if l == (-1)
then
else return (fromIntegral l)
asyncReadRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncRead fd (if is_stream then 1 else 0)
+ (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) (buf `plusPtr` off)
if l == (-1)
then
else return (fromIntegral l)
asyncWriteRawBuffer loc fd is_stream buf off len = do
- (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0)
+ (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) off buf
if l == (-1)
then
else return (fromIntegral l)
asyncWriteRawBufferPtr loc fd is_stream buf off len = do
- (l, rc) <- asyncWrite fd (if is_stream then 1 else 0)
+ (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0)
(fromIntegral len) (buf `plusPtr` off)
if l == (-1)
then
blockingReadRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- recv_rawBuffer fd buf off len
+ safe_recv_rawBuffer fd buf off len
blockingReadRawBuffer loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- read_rawBuffer fd buf off len
+ safe_read_rawBuffer fd buf off len
blockingReadRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- recv_off fd buf off len
+ safe_recv_off fd buf off len
blockingReadRawBufferPtr loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- read_off fd buf off len
+ safe_read_off fd buf off len
blockingWriteRawBuffer loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- send_rawBuffer (fromIntegral fd) buf off len
+ safe_send_rawBuffer fd buf off len
blockingWriteRawBuffer loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- write_rawBuffer (fromIntegral fd) buf off len
+ safe_write_rawBuffer fd buf off len
blockingWriteRawBufferPtr loc fd True buf off len =
throwErrnoIfMinus1Retry loc $
- send_off (fromIntegral fd) buf off len
+ safe_send_off fd buf off len
blockingWriteRawBufferPtr loc fd False buf off len =
throwErrnoIfMinus1Retry loc $
- write_off (fromIntegral fd) buf off len
+ safe_write_off fd buf off len
-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
-- These calls may block, but that's ok.
-foreign import ccall safe "__hscore_PrelHandle_read"
- read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_read"
- read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall safe "__hscore_PrelHandle_write"
- write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-
foreign import ccall safe "__hscore_PrelHandle_recv"
- recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+ safe_recv_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall safe "__hscore_PrelHandle_recv"
- recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+ safe_recv_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
foreign import ccall safe "__hscore_PrelHandle_send"
- send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+ safe_send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall safe "__hscore_PrelHandle_send"
- send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+ safe_send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
#endif
+foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ safe_read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_read"
+ safe_read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ safe_write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_write"
+ safe_write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+
-- ---------------------------------------------------------------------------
-- Standard Handles
stdin :: Handle
stdin = unsafePerformIO $ do
-- ToDo: acquire lock
- setNonBlockingFD fd_stdin
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
(buf, bmode) <- getBuffer fd_stdin ReadBuffer
mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
stdout :: Handle
stdout = unsafePerformIO $ do
-- ToDo: acquire lock
- -- We don't set non-blocking mode on stdout or sterr, because
- -- some shells don't recover properly.
- -- setNonBlockingFD fd_stdout
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
(buf, bmode) <- getBuffer fd_stdout WriteBuffer
mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
stderr :: Handle
stderr = unsafePerformIO $ do
-- ToDo: acquire lock
- -- We don't set non-blocking mode on stdout or sterr, because
- -- some shells don't recover properly.
- -- setNonBlockingFD fd_stderr
+ -- We don't set non-blocking mode on standard handles, because it may
+ -- confuse other applications attached to the same TTY/pipe
+ -- see Note [nonblock]
buf <- mkUnBuffer
mkStdHandle fd_stderr "<stderr>" WriteHandle buf NoBuffering
-- * 'isDoesNotExistError' if the file does not exist; or
--
-- * 'isPermissionError' if the user does not have permission to open the file.
-
+--
+-- Note: if you will be working with files containing binary data, you'll want to
+-- be using 'openBinaryFile'.
openFile :: FilePath -> IOMode -> IO Handle
openFile fp im =
catch
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
- truncate | WriteMode <- mode = True
- | otherwise = False
-
binary_flags
| binary = o_BINARY
| otherwise = 0
-- directories. However, the man pages I've read say that open()
-- always returns EISDIR if the file is a directory and was opened
-- for writing, so I think we're ok with a single open() here...
- fd <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "openFile"
+ fd <- throwErrnoIfMinus1Retry "openFile"
(c_open f (fromIntegral oflags) 0o666)
- openFd fd Nothing False filepath mode binary truncate
- `catchException` \e -> do c_close (fromIntegral fd); throw e
+ fd_type <- fdType fd
+
+ h <- openFd fd (Just fd_type) False filepath mode binary
+ `catchException` \e -> do c_close 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
+ -- we want to truncate() if this is an open in WriteMode, but only
+ -- if the target is a RegularFile. ftruncate() fails on special files
+ -- like /dev/null.
+ if mode == WriteMode && fd_type == RegularFile
+ then throwErrnoIf (/=0) "openFile"
+ (c_ftruncate 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 fd Nothing False filepath ReadWriteMode True
+ `catchException` \e -> do c_close fd; throw e
+ return (filepath, h)
+ where
+ filename = prefix ++ show x ++ suffix
+ filepath = tmp_dir ++ [pathSeparator] ++ filename
+
+pathSeparator :: Char
+#ifdef mingw32_HOST_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
std_flags = o_NONBLOCK .|. o_NOCTTY
output_flags = std_flags .|. o_CREAT
-- ---------------------------------------------------------------------------
-- openFd
-openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
-openFd fd mb_fd_type is_socket filepath mode binary truncate = do
+openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle
+openFd fd mb_fd_type is_socket filepath mode binary = do
-- turn on non-blocking mode
setNonBlockingFD fd
+#ifdef mingw32_HOST_OS
+ -- On Windows, the is_stream flag indicates that the Handle is a socket
+ let is_stream = is_socket
+#else
+ -- On Unix, the is_stream flag indicates that the FD is non-blocking
+ let is_stream = True
+#endif
+
let (ha_type, write) =
case mode of
ReadMode -> ( ReadHandle, False )
ioException (IOError Nothing InappropriateType "openFile"
"is a directory" Nothing)
- Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary
- | otherwise -> mkFileHandle fd is_socket filepath ha_type binary
-
-- regular files need to be locked
RegularFile -> do
- r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+#ifndef mingw32_HOST_OS
+ r <- lockFile fd (fromBool write) 1{-exclusive-}
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
"file is locked" Nothing)
+#endif
+ mkFileHandle fd is_stream filepath ha_type binary
- -- truncate the file if necessary
- when truncate (fileTruncate filepath)
-
- mkFileHandle fd is_socket filepath ha_type binary
+ Stream
+ -- only *Streams* can be DuplexHandles. Other read/write
+ -- Handles must share a buffer.
+ | ReadWriteHandle <- ha_type ->
+ mkDuplexHandle fd is_stream filepath binary
+ | otherwise ->
+ mkFileHandle fd is_stream filepath ha_type binary
+ RawDevice ->
+ mkFileHandle fd is_stream filepath ha_type binary
fdToHandle :: FD -> IO Handle
fdToHandle fd = do
mode <- fdGetMode fd
let fd_str = "<file descriptor: " ++ show fd ++ ">"
- openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} False{-no truncate-}
+ openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
+
+#ifndef mingw32_HOST_OS
foreign import ccall unsafe "lockFile"
lockFile :: CInt -> CInt -> CInt -> IO CInt
foreign import ccall unsafe "unlockFile"
unlockFile :: CInt -> IO CInt
+#endif
mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
-> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
spares <- newIORef BufferListNil
- newFileHandle filepath stdHandleFinalizer
+ newFileHandle filepath (stdHandleFinalizer filepath)
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haIsStream = False,
+ haIsStream = False, -- means FD is blocking on Unix
haBufferMode = bmode,
haBuffer = buf,
haBuffers = spares,
mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
+
+#ifdef mingw32_HOST_OS
+ -- On Windows, if this is a read/write handle and we are in text mode,
+ -- turn off buffering. We don't correctly handle the case of switching
+ -- from read mode to write mode on a buffered text-mode handle, see bug
+ -- \#679.
+ bmode <- case ha_type of
+ ReadWriteHandle | not binary -> return NoBuffering
+ _other -> return bmode
+#endif
+
spares <- newIORef BufferListNil
- newFileHandle filepath handleFinalizer
+ newFileHandle filepath (handleFinalizer filepath)
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = binary,
}
read_side <- newMVar r_handle_
- addMVarFinalizer write_side (handleFinalizer write_side)
+ addMVarFinalizer write_side (handleFinalizer filepath write_side)
return (DuplexHandle filepath read_side write_side)
hClose_handle_ handle_ = do
let fd = haFD handle_
- 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) $
+ Nothing ->
throwErrnoIfMinus1Retry_ "hClose"
-#ifdef mingw32_TARGET_OS
- (closeFd (haIsStream handle_) c_fd)
+#ifdef mingw32_HOST_OS
+ (closeFd (haIsStream handle_) fd)
#else
- (c_close c_fd)
+ (c_close fd)
#endif
Just _ -> return ()
-- free the spare buffers
writeIORef (haBuffers handle_) BufferListNil
+#ifndef mingw32_HOST_OS
-- unlock it
- unlockFile c_fd
-
+ unlockFile fd
+#endif
+
-- we must set the fd to -1, because the finalizer is going
-- to run eventually and try to close/unlock it.
return (handle_{ haFD = -1,
})
-----------------------------------------------------------------------------
--- Detecting the size of a file
+-- Detecting and changing the size of a file
-- | For a handle @hdl@ which attached to a physical file,
-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
else ioException (IOError Nothing InappropriateType "hFileSize"
"not a regular file" Nothing)
+
+-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
+
+hSetFileSize :: Handle -> Integer -> IO ()
+hSetFileSize handle size =
+ withHandle_ "hSetFileSize" handle $ \ handle_ -> do
+ case haType handle_ of
+ ClosedHandle -> ioe_closedHandle
+ SemiClosedHandle -> ioe_closedHandle
+ _ -> do flushWriteBufferOnly handle_
+ throwErrnoIf (/=0) "hSetFileSize"
+ (c_ftruncate (haFD handle_) (fromIntegral size))
+ return ()
+
-- ---------------------------------------------------------------------------
-- Detecting the End of Input
-- fill up the read buffer if necessary
new_buf <- if bufferEmpty buf
- then fillReadBuffer fd is_line (haIsStream handle_) buf
+ then fillReadBuffer fd True (haIsStream handle_) buf
else return buf
writeIORef ref new_buf
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
+#else
+ NoBuffering -> return ()
#endif
_ -> setCooked (haFD handle_) True
let do_seek =
throwErrnoIfMinus1Retry_ "hSeek"
- (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+ (c_lseek (haFD handle_) (fromIntegral offset) whence)
whence :: CInt
whence = case mode of
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.
flushBuffer handle_
#endif
- let fd = fromIntegral (haFD handle_)
+ let fd = haFD handle_
posn <- fromIntegral `liftM`
throwErrnoIfMinus1Retry "hGetPosn"
(c_lseek fd 0 sEEK_CUR)
SemiClosedHandle -> ioe_closedHandle
AppendHandle -> return False
_ -> do t <- fdType (haFD handle_)
- return (t == RegularFile
- && (haIsBin handle_
- || tEXT_MODE_SEEK_ALLOWED))
+ return ((t == RegularFile || t == RawDevice)
+ && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
-- Changing echo status (Non-standard GHC extensions)
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
do throwErrnoIfMinus1_ "hSetBinaryMode"
- (setmode (fromIntegral (haFD handle_)) bin)
+ (setmode (haFD handle_) bin)
return handle_{haIsBin=bin}
foreign import ccall unsafe "__hscore_setmode"
-- -----------------------------------------------------------------------------
-- Duplicating a Handle
--- |Returns a duplicate of the original handle, with its own buffer
--- and file pointer. The original handle's buffer is flushed, including
--- discarding any input data, before the handle is duplicated.
+-- | Returns a duplicate of the original handle, with its own buffer.
+-- The two Handles will share a file pointer, however. The original
+-- handle's buffer is flushed, including discarding any input data,
+-- before the handle is duplicated.
hDuplicate :: Handle -> IO Handle
hDuplicate h@(FileHandle path m) = do
- new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
- new_m <- newMVar new_h_
- return (FileHandle path new_m)
+ new_h_ <- withHandle' "hDuplicate" h m (dupHandle h Nothing)
+ newFileHandle path (handleFinalizer path) new_h_
hDuplicate h@(DuplexHandle path r w) = do
- new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
+ new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing)
new_w <- newMVar new_w_
- new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
+ new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (Just new_w))
new_r <- newMVar new_r_
+ addMVarFinalizer new_w (handleFinalizer path new_w)
return (DuplexHandle path new_r new_w)
-dupHandle_ other_side h_ = do
+dupHandle :: Handle -> Maybe (MVar Handle__) -> Handle__
+ -> IO (Handle__, Handle__)
+dupHandle h other_side h_ = do
-- flush the buffer first, so we don't have to copy its contents
flushBuffer h_
- new_fd <- c_dup (fromIntegral (haFD h_))
+ new_fd <- case other_side of
+ Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
+ Just r -> withHandle_' "dupHandle" h r (return . haFD)
+ dupHandle_ other_side h_ new_fd
+
+dupHandleTo other_side hto_ h_ = do
+ flushBuffer h_
+ -- Windows' dup2 does not return the new descriptor, unlike Unix
+ throwErrnoIfMinus1 "dupHandleTo" $
+ c_dup2 (haFD h_) (haFD hto_)
+ dupHandle_ other_side h_ (haFD hto_)
+
+dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
+ -> IO (Handle__, Handle__)
+dupHandle_ other_side h_ new_fd = do
buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
ioref <- newIORef buffer
ioref_buffers <- newIORef BufferListNil
- let new_handle_ = h_{ haFD = fromIntegral new_fd,
+ let new_handle_ = h_{ haFD = new_fd,
haBuffer = ioref,
haBuffers = ioref_buffers,
haOtherSide = other_side }
hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
_ <- hClose_help h2_
- withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
+ withHandle' "hDuplicateTo" h1 m1 (dupHandleTo Nothing h2_)
hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
_ <- hClose_help w2_
- withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
+ withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_)
withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
_ <- hClose_help r2_
- withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
+ withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
hDuplicateTo h1 _ =
ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
"handles are incompatible" Nothing)
-- ---------------------------------------------------------------------------
-- debugging
-#ifdef DEBUG_DUMP
+#if defined(DEBUG_DUMP)
puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
- return ()
+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
+ return ()
#endif
-- -----------------------------------------------------------------------------
projects / ghc-base.git / blobdiff