-{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
#undef DEBUG_DUMP
#undef DEBUG
--- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.6 2002/03/26 17:06:32 simonmar Exp $
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Handle
+-- Copyright : (c) The University of Glasgow, 1994-2001
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
--
--- (c) The University of Glasgow, 1994-2001
+-- This module defines the basic operations on I\/O \"handles\".
--
--- This module defines the basic operations on I/O "handles".
+-----------------------------------------------------------------------------
+-- #hide
module GHC.Handle (
withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
- read_off, read_off_ba,
- write_off, write_off_ba,
+ flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer,
+ fillReadBuffer, fillReadBufferWithoutBlocking,
+ readRawBuffer, readRawBufferPtr,
+ writeRawBuffer, writeRawBufferPtr,
+
+#ifndef mingw32_HOST_OS
+ unlockFile,
+#endif
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
- IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
- hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
- hFlush,
+ IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle,
+ hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
- HandlePosn(..), hGetPosn, hSetPosn,
+ HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
SeekMode(..), hSeek, hTell,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
hSetEcho, hGetEcho, hIsTerminalDevice,
+ hShow,
+
#ifdef DEBUG_DUMP
puts,
#endif
) where
+import System.Directory.Internals
import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import System.IO.Error
+import System.Posix.Internals
-import GHC.Posix
import GHC.Real
import GHC.Arr
import GHC.Num ( Integer(..), Num(..) )
import GHC.Show
import GHC.Real ( toInteger )
+#if defined(DEBUG_DUMP)
+import GHC.Pack
+#endif
import GHC.Conc
-- ---------------------------------------------------------------------------
-- Creating a new handle
-newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle finalizer hc = do
+newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle filepath finalizer hc = do
m <- newMVar hc
addMVarFinalizer m (finalizer m)
- return (FileHandle m)
+ return (FileHandle filepath m)
-- ---------------------------------------------------------------------------
-- Working with Handles
{-# INLINE withHandle #-}
withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle fun h@(FileHandle m) act = withHandle' fun h m act
-withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
+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 (Handle__,a)) -> IO a
h_ <- takeMVar m
checkBufferInvariants h_
(h',v) <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return v
{-# INLINE withHandle_ #-}
withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
-withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
-withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
+withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
+withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
withHandle_' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
v <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h_
putMVar m h_
return v
withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
-withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
-withAllHandles__ fun h@(DuplexHandle r w) act = do
+withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle _ r w) act = do
withHandle__' fun h r act
withHandle__' fun h w act
h_ <- takeMVar m
checkBufferInvariants h_
h' <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return ()
-augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
- = IOException (IOError (Just h) iot fun str filepath)
- where filepath | Just _ <- fp = fp
- | otherwise = Just (haFilePath h_)
-augmentIOError other_exception _ _ _
- = other_exception
+augmentIOError (IOError _ iot _ str fp) fun h
+ = IOError (Just h) iot fun str filepath
+ where filepath
+ | Just _ <- fp = fp
+ | otherwise = case h of
+ FileHandle fp _ -> Just fp
+ DuplexHandle fp _ _ -> Just fp
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantWritableHandle fun h@(FileHandle m) act
+wantWritableHandle fun h@(FileHandle _ m) act
= wantWritableHandle' fun h m act
-wantWritableHandle fun h@(DuplexHandle _ m) act
+wantWritableHandle fun h@(DuplexHandle _ _ m) act
= wantWritableHandle' fun h m act
-- ToDo: in the Duplex case, we don't need to checkWritableHandle
-- Wrapper for read operations.
wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantReadableHandle fun h@(FileHandle m) act
+wantReadableHandle fun h@(FileHandle _ m) act
= wantReadableHandle' fun h m act
-wantReadableHandle fun h@(DuplexHandle m _) act
+wantReadableHandle fun h@(DuplexHandle _ m _) act
= wantReadableHandle' fun h m act
-- ToDo: in the Duplex case, we don't need to checkReadableHandle
-- Wrapper for seek operations.
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantSeekableHandle fun h@(DuplexHandle _ _) _act =
+wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
ioException (IOError (Just h) IllegalOperation fun
"handle is not seekable" Nothing)
-wantSeekableHandle fun h@(FileHandle m) act =
+wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
checkSeekableHandle act handle_ =
"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
- h_ <- takeMVar m
- flushWriteBufferOnly h_
+-- 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.
-handleFinalizer :: MVar Handle__ -> IO ()
-handleFinalizer m = do
+stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+stdHandleFinalizer fp m = do
h_ <- takeMVar m
flushWriteBufferOnly h_
- let fd = fromIntegral (haFD h_)
- unlockFile fd
- when (fd /= -1)
-#ifdef mingw32_TARGET_OS
- (closeFd (haIsStream h_) fd >> return ())
-#else
- (c_close fd >> return ())
-#endif
- return ()
+ putMVar m (ioe_finalizedHandle fp)
+
+handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
+handleFinalizer fp m = do
+ handle_ <- takeMVar m
+ case haType handle_ of
+ ClosedHandle -> return ()
+ _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+ -- ignore errors and async exceptions, and close the
+ -- 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_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
+ -- be moved around by the GC.
+ case newPinnedByteArray# size s of { (# s, b #) ->
+#else
case newByteArray# size s of { (# s, b #) ->
+#endif
(# s, newEmptyBuffer b state sz #) }
writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
return buf{ bufWPtr=0, bufRPtr=0 }
flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
-flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
+flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } =
+ seq fd $ do -- strictness hack
let bytes = w - r
#ifdef DEBUG_DUMP
puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n")
if bytes == 0
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
- res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
- (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
- (fromIntegral bytes))
- (threadWaitWrite fd)
+ res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
+ (fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
else return buf{ bufRPtr=0, bufWPtr=0 }
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
- res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
- (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
- (threadWaitRead fd)
+ res <- readRawBuffer "fillReadBuffer" fd is_stream b
+ (fromIntegral w) (fromIntegral bytes)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBufferWithoutBlocking fd is_stream
+ buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+ -- buffer better be empty:
+ assert (r == 0 && w == 0) $ do
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
+#endif
+ res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
+ 0 (fromIntegral size)
+ let res' = fromIntegral res
+#ifdef DEBUG_DUMP
+ puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n")
+#endif
+ return buf{ bufRPtr=0, bufWPtr=res' }
+
+-- Low level routines for reading/writing to (raw)buffers:
+
+#ifndef mingw32_HOST_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 (fromIntegral fd))
+
+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)
+
+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 (fromIntegral fd))
+
+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 (fromIntegral fd))
+
+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 (fromIntegral fd))
+
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+ read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+ read_off :: FD -> 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_HOST_OS.... */
+
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_stream buf off len
+ | threaded = blockingReadRawBuffer loc fd is_stream buf off len
+ | otherwise = asyncReadRawBuffer loc fd is_stream buf off len
+
+readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtr loc fd is_stream buf off len
+ | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len
+ | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len
+
+writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+writeRawBuffer loc fd is_stream buf off len
+ | threaded = blockingWriteRawBuffer loc fd is_stream buf off len
+ | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len
+
+writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc fd is_stream buf off len
+ | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len
+ | otherwise = asyncWriteRawBufferPtr 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
+
+-- 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)
+ (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncReadRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncRead fd (if is_stream then 1 else 0)
+ (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncWriteRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0)
+ (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+asyncWriteRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncWrite fd (if is_stream then 1 else 0)
+ (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+-- Blocking versions of the read/write primitives, for the threaded RTS
+
+blockingReadRawBuffer loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ recv_rawBuffer fd buf off len
+blockingReadRawBuffer loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ read_rawBuffer fd buf off len
+
+blockingReadRawBufferPtr loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ recv_off fd buf off len
+blockingReadRawBufferPtr loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ read_off fd buf off len
+
+blockingWriteRawBuffer loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ send_rawBuffer (fromIntegral fd) buf off len
+blockingWriteRawBuffer loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ write_rawBuffer (fromIntegral fd) buf off len
+
+blockingWriteRawBufferPtr loc fd True buf off len =
+ throwErrnoIfMinus1Retry loc $
+ send_off (fromIntegral fd) buf off len
+blockingWriteRawBufferPtr loc fd False buf off len =
+ throwErrnoIfMinus1Retry loc $
+ write_off (fromIntegral 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
+
+foreign import ccall safe "__hscore_PrelHandle_recv"
+ recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_send"
+ send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall safe "__hscore_PrelHandle_send"
+ send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool
+#endif
-- ---------------------------------------------------------------------------
-- Standard Handles
fd_stdout = 1 :: FD
fd_stderr = 2 :: FD
+-- | A handle managing input from the Haskell program's standard input channel.
stdin :: Handle
stdin = unsafePerformIO $ do
-- ToDo: acquire lock
(buf, bmode) <- getBuffer fd_stdin ReadBuffer
mkStdHandle fd_stdin "<stdin>" ReadHandle buf bmode
+-- | A handle managing output to the Haskell program's standard output channel.
stdout :: Handle
stdout = unsafePerformIO $ do
-- ToDo: acquire lock
(buf, bmode) <- getBuffer fd_stdout WriteBuffer
mkStdHandle fd_stdout "<stdout>" WriteHandle buf bmode
+-- | A handle managing output to the Haskell program's standard error channel.
stderr :: Handle
stderr = unsafePerformIO $ do
-- ToDo: acquire lock
-- ---------------------------------------------------------------------------
-- Opening and Closing Files
-{-
-Computation `openFile file mode' allocates and returns a new, open
-handle to manage the file `file'. It manages input if `mode'
-is `ReadMode', output if `mode' is `WriteMode' or `AppendMode',
-and both input and output if mode is `ReadWriteMode'.
-
-If the file does not exist and it is opened for output, it should be
-created as a new file. If `mode' is `WriteMode' and the file
-already exists, then it should be truncated to zero length. The
-handle is positioned at the end of the file if `mode' is
-`AppendMode', and otherwise at the beginning (in which case its
-internal position is 0).
-
-Implementations should enforce, locally to the Haskell process,
-multiple-reader single-writer locking on files, which is to say that
-there may either be many handles on the same file which manage input,
-or just one handle on the file which manages output. If any open or
-semi-closed handle is managing a file for output, no new handle can be
-allocated for that file. If any open or semi-closed handle is
-managing a file for input, new handles can only be allocated if they
-do not manage output.
-
-Two files are the same if they have the same absolute name. An
-implementation is free to impose stricter conditions.
--}
-
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-data IOModeEx
- = BinaryMode IOMode
- | TextMode IOMode
- deriving (Eq, Read, Show)
-
-addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
- = IOException (IOError h iot fun str (Just fp))
-addFilePathToIOError _ _ other_exception
- = other_exception
+addFilePathToIOError fun fp (IOError h iot _ str _)
+ = IOError h iot fun str (Just fp)
+-- | Computation 'openFile' @file mode@ allocates and returns a new, open
+-- handle to manage the file @file@. It manages input if @mode@
+-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode',
+-- and both input and output if mode is 'ReadWriteMode'.
+--
+-- If the file does not exist and it is opened for output, it should be
+-- created as a new file. If @mode@ is 'WriteMode' and the file
+-- already exists, then it should be truncated to zero length.
+-- Some operating systems delete empty files, so there is no guarantee
+-- that the file will exist following an 'openFile' with @mode@
+-- 'WriteMode' unless it is subsequently written to successfully.
+-- The handle is positioned at the end of the file if @mode@ is
+-- 'AppendMode', and otherwise at the beginning (in which case its
+-- internal position is 0).
+-- The initial buffer mode is implementation-dependent.
+--
+-- This operation may fail with:
+--
+-- * 'isAlreadyInUseError' if the file is already open and cannot be reopened;
+--
+-- * '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
- (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
- then BinaryMode im
- else TextMode im))
- (\e -> throw (addFilePathToIOError "openFile" fp e))
-
-openFileEx :: FilePath -> IOModeEx -> IO Handle
-openFileEx fp m =
+ (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
+ (\e -> ioError (addFilePathToIOError "openFile" fp e))
+
+-- | Like 'openFile', but open the file in binary mode.
+-- On Windows, reading a file in text mode (which is the default)
+-- will translate CRLF to LF, and writing will translate LF to CRLF.
+-- This is usually what you want with text files. With binary files
+-- this is undesirable; also, as usual under Microsoft operating systems,
+-- text mode treats control-Z as EOF. Binary mode turns off all special
+-- treatment of end-of-line and end-of-file characters.
+-- (See also 'hSetBinaryMode'.)
+
+openBinaryFile :: FilePath -> IOMode -> IO Handle
+openBinaryFile fp m =
catch
- (openFile' fp m)
- (\e -> throw (addFilePathToIOError "openFileEx" fp e))
-
+ (openFile' fp m True)
+ (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
-openFile' filepath ex_mode =
+openFile' filepath mode binary =
withCString filepath $ \ f ->
let
- (mode, binary) =
- case ex_mode of
- BinaryMode bmo -> (bmo, True)
- TextMode tmo -> (tmo, False)
-
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
throwErrnoIfMinus1Retry "openFile"
(c_open f (fromIntegral oflags) 0o666)
- openFd fd Nothing filepath mode binary truncate
+ fd_type <- fdType fd
+
+ h <- openFd fd (Just fd_type) 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
+ -- 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 (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
-- ---------------------------------------------------------------------------
-- openFd
-openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
-openFd fd mb_fd_type 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
case mb_fd_type of
Just x -> return x
Nothing -> fdType fd
- let is_stream = fd_type == Stream
+
case fd_type of
Directory ->
ioException (IOError Nothing InappropriateType "openFile"
"is a directory" Nothing)
Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary
- | otherwise -> mkFileHandle fd is_stream filepath ha_type binary
+ | 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
+#ifndef mingw32_HOST_OS
r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
"file is locked" Nothing)
+#endif
+ mkFileHandle fd is_socket filepath ha_type binary
- -- truncate the file if necessary
- when truncate (fileTruncate filepath)
- 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-}
+#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 stdHandleFinalizer
+ newFileHandle filepath (stdHandleFinalizer filepath)
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
haIsStream = False,
haBufferMode = bmode,
- haFilePath = filepath,
haBuffer = buf,
haBuffers = spares,
haOtherSide = Nothing
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
spares <- newIORef BufferListNil
- newFileHandle handleFinalizer
+ newFileHandle filepath (handleFinalizer filepath)
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = bmode,
- haFilePath = filepath,
haBuffer = buf,
haBuffers = spares,
haOtherSide = Nothing
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = w_bmode,
- haFilePath = filepath,
haBuffer = w_buf,
haBuffers = w_spares,
haOtherSide = Nothing
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = r_bmode,
- haFilePath = filepath,
haBuffer = r_buf,
haBuffers = r_spares,
haOtherSide = Just write_side
}
read_side <- newMVar r_handle_
- addMVarFinalizer read_side (handleFinalizer read_side)
- return (DuplexHandle read_side write_side)
+ addMVarFinalizer write_side (handleFinalizer filepath write_side)
+ return (DuplexHandle filepath read_side write_side)
initBufferState ReadHandle = ReadBuffer
-- ---------------------------------------------------------------------------
-- Closing a handle
--- Computation `hClose hdl' makes handle `hdl' closed. Before the
--- computation finishes, any items buffered for output and not already
--- sent to the operating system are flushed as for `hFlush'.
-
--- For a duplex handle, we close&flush the write side, and just close
--- the read side.
+-- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the
+-- computation finishes, if @hdl@ is writable its buffer is flushed as
+-- for 'hFlush'.
+-- Performing 'hClose' on a handle that has already been closed has no effect;
+-- doing so not an error. All other operations on a closed handle will fail.
+-- If 'hClose' fails for any reason, any further operations (apart from
+-- 'hClose') on the handle will still fail as if @hdl@ had been successfully
+-- closed.
hClose :: Handle -> IO ()
-hClose h@(FileHandle m) = hClose' h m
-hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
+hClose h@(FileHandle _ m) = hClose' h m
+hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
hClose' h m = withHandle__' "hClose" h m $ hClose_help
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return handle_
- _ -> do
- let fd = haFD handle_
- c_fd = fromIntegral fd
-
- flushWriteBufferOnly handle_
-
- -- 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.
- case haOtherSide handle_ of
- Nothing ->
- when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
- throwErrnoIfMinus1Retry_ "hClose"
-#ifdef mingw32_TARGET_OS
+ _ -> do flushWriteBufferOnly handle_ -- interruptible
+ hClose_handle_ handle_
+
+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.
+ case haOtherSide handle_ of
+ Nothing ->
+ throwErrnoIfMinus1Retry_ "hClose"
+#ifdef mingw32_HOST_OS
(closeFd (haIsStream handle_) c_fd)
#else
(c_close c_fd)
#endif
- Just _ -> return ()
+ Just _ -> return ()
- -- free the spare buffers
- writeIORef (haBuffers handle_) BufferListNil
-
- -- unlock it
- unlockFile c_fd
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+#ifndef mingw32_HOST_OS
+ -- unlock it
+ unlockFile c_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,
- haType = ClosedHandle
- })
+ -- 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,
+ haType = ClosedHandle
+ })
-----------------------------------------------------------------------------
--- 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 `hdl' in terms of the number of items
--- which can be read from `hdl'.
+-- | For a handle @hdl@ which attached to a physical file,
+-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
hFileSize :: Handle -> IO Integer
hFileSize handle =
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 (fromIntegral (haFD handle_)) (fromIntegral size))
+ return ()
+
-- ---------------------------------------------------------------------------
-- Detecting the End of Input
--- For a readable handle `hdl', `hIsEOF hdl' returns
--- `True' if no further input can be taken from `hdl' or for a
--- physical file, if the current I/O position is equal to the length of
--- the file. Otherwise, it returns `False'.
+-- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
+-- 'True' if no further input can be taken from @hdl@ or for a
+-- physical file, if the current I\/O position is equal to the length of
+-- the file. Otherwise, it returns 'False'.
hIsEOF :: Handle -> IO Bool
hIsEOF handle =
catch
(do hLookAhead handle; return False)
- (\e -> if isEOFError e then return True else throw e)
+ (\e -> if isEOFError e then return True else ioError e)
+
+-- | The computation 'isEOF' is identical to 'hIsEOF',
+-- except that it works only on 'stdin'.
isEOF :: IO Bool
isEOF = hIsEOF stdin
-- ---------------------------------------------------------------------------
-- Looking ahead
--- hLookahead returns the next character from the handle without
--- removing it from the input buffer, blocking until a character is
--- available.
+-- | Computation 'hLookAhead' returns the next character from the handle
+-- without removing it from the input buffer, blocking until a character
+-- is available.
+--
+-- This operation may fail with:
+--
+-- * 'isEOFError' if the end of file has been reached.
hLookAhead :: Handle -> IO Char
hLookAhead handle = do
-- block-buffering or no-buffering. See GHC.IOBase for definition and
-- further explanation of what the type represent.
--- Computation `hSetBuffering hdl mode' sets the mode of buffering for
--- handle hdl on subsequent reads and writes.
+-- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
+-- handle @hdl@ on subsequent reads and writes.
--
--- * If mode is LineBuffering, line-buffering should be enabled if possible.
+-- If the buffer mode is changed from 'BlockBuffering' or
+-- 'LineBuffering' to 'NoBuffering', then
--
--- * If mode is `BlockBuffering size', then block-buffering
--- should be enabled if possible. The size of the buffer is n items
--- if size is `Just n' and is otherwise implementation-dependent.
+-- * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
--
--- * If mode is NoBuffering, then buffering is disabled if possible.
-
--- If the buffer mode is changed from BlockBuffering or
--- LineBuffering to NoBuffering, then any items in the output
--- buffer are written to the device, and any items in the input buffer
--- are discarded. The default buffering mode when a handle is opened
--- is implementation-dependent and may depend on the object which is
--- attached to that handle.
+-- * if @hdl@ is not writable, the contents of the buffer is discarded.
+--
+-- This operation may fail with:
+--
+-- * 'isPermissionError' if the handle has already been used for reading
+-- or writing and the implementation does not allow the buffering mode
+-- to be changed.
hSetBuffering :: Handle -> BufferMode -> IO ()
hSetBuffering handle mode =
is_tty <- fdIsTTY (haFD handle_)
when (is_tty && isReadableHandleType (haType handle_)) $
case mode of
+#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
-- throw away spare buffers, they might be the wrong size
-- -----------------------------------------------------------------------------
-- hFlush
--- The action `hFlush hdl' causes any items buffered for output
--- in handle `hdl' to be sent immediately to the operating
--- system.
+-- | The action 'hFlush' @hdl@ causes any items buffered for output
+-- in handle @hdl@ to be sent immediately to the operating system.
+--
+-- This operation may fail with:
+--
+-- * 'isFullError' if the device is full;
+--
+-- * 'isPermissionError' if a system resource limit would be exceeded.
+-- It is unspecified whether the characters in the buffer are discarded
+-- or retained under these circumstances.
hFlush :: Handle -> IO ()
hFlush handle =
writeIORef (haBuffer handle_) flushed_buf
else return ()
-
+
-- -----------------------------------------------------------------------------
-- Repositioning Handles
-- that reports the position back via (merely) an Int.
type HandlePosition = Integer
--- Computation `hGetPosn hdl' returns the current I/O position of
--- `hdl' as an abstract position. Computation `hSetPosn p' sets the
--- position of `hdl' to a previously obtained position `p'.
+-- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
+-- @hdl@ as a value of the abstract type 'HandlePosn'.
hGetPosn :: Handle -> IO HandlePosn
hGetPosn handle = do
posn <- hTell handle
return (HandlePosn handle posn)
+-- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
+-- then computation 'hSetPosn' @p@ sets the position of @hdl@
+-- to the position it held at the time of the call to 'hGetPosn'.
+--
+-- This operation may fail with:
+--
+-- * 'isPermissionError' if a system resource limit would be exceeded.
+
hSetPosn :: HandlePosn -> IO ()
hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
-- ---------------------------------------------------------------------------
-- hSeek
-{-
-The action `hSeek hdl mode i' sets the position of handle
-`hdl' depending on `mode'. If `mode' is
-
- * AbsoluteSeek - The position of `hdl' is set to `i'.
- * RelativeSeek - The position of `hdl' is set to offset `i' from
- the current position.
- * SeekFromEnd - The position of `hdl' is set to offset `i' from
- the end of the file.
-
-Some handles may not be seekable (see `hIsSeekable'), or only
-support a subset of the possible positioning operations (e.g. it may
-only be possible to seek to the end of a tape, or to a positive
-offset from the beginning or current position).
-
-It is not possible to set a negative I/O position, or for a physical
-file, an I/O position beyond the current end-of-file.
+-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows:
+data SeekMode
+ = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@.
+ | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@
+ -- from the current position.
+ | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@
+ -- from the end of the file.
+ deriving (Eq, Ord, Ix, Enum, Read, Show)
-Note:
+{- Note:
- when seeking using `SeekFromEnd', positive offsets (>=0) means
seeking at or past EOF.
clear here.
-}
-data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
- deriving (Eq, Ord, Ix, Enum, Read, Show)
+-- | Computation 'hSeek' @hdl mode i@ sets the position of handle
+-- @hdl@ depending on @mode@.
+-- The offset @i@ is given in terms of 8-bit bytes.
+--
+-- If @hdl@ is block- or line-buffered, then seeking to a position which is not
+-- in the current buffer will first cause any items in the output buffer to be
+-- written to the device, and then cause the input buffer to be discarded.
+-- Some handles may not be seekable (see 'hIsSeekable'), or only support a
+-- subset of the possible positioning operations (for instance, it may only
+-- be possible to seek to the end of a tape, or to a positive offset from
+-- the beginning or current position).
+-- It is not possible to set a negative I\/O position, or for
+-- a physical file, an I\/O position beyond the current end-of-file.
+--
+-- This operation may fail with:
+--
+-- * 'isPermissionError' if a system resource limit would be exceeded.
hSeek :: Handle -> SeekMode -> Integer -> IO ()
hSeek handle mode offset =
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.
-}
hIsReadable :: Handle -> IO Bool
-hIsReadable (DuplexHandle _ _) = return True
+hIsReadable (DuplexHandle _ _ _) = return True
hIsReadable handle =
withHandle_ "hIsReadable" handle $ \ handle_ -> do
case haType handle_ of
htype -> return (isReadableHandleType htype)
hIsWritable :: Handle -> IO Bool
-hIsWritable (DuplexHandle _ _) = return False
+hIsWritable (DuplexHandle _ _ _) = return True
hIsWritable handle =
withHandle_ "hIsWritable" handle $ \ handle_ -> do
case haType handle_ of
SemiClosedHandle -> ioe_closedHandle
htype -> return (isWritableHandleType htype)
--- Querying how a handle buffers its data:
+-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
+-- for @hdl@.
hGetBuffering :: Handle -> IO BufferMode
hGetBuffering handle =
|| tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
--- Changing echo status
+-- Changing echo status (Non-standard GHC extensions)
--- Non-standard GHC extension is to allow the echoing status
--- of a handles connected to terminals to be reconfigured:
+-- | Set the echoing status of a handle connected to a terminal.
hSetEcho :: Handle -> Bool -> IO ()
hSetEcho handle on = do
ClosedHandle -> ioe_closedHandle
_ -> setEcho (haFD handle_) on
+-- | Get the echoing status of a handle connected to a terminal.
+
hGetEcho :: Handle -> IO Bool
hGetEcho handle = do
isT <- hIsTerminalDevice handle
ClosedHandle -> ioe_closedHandle
_ -> getEcho (haFD handle_)
+-- | Is the handle connected to a terminal?
+
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
-- -----------------------------------------------------------------------------
-- hSetBinaryMode
+-- | Select binary mode ('True') or text mode ('False') on a open handle.
+-- (See also 'openBinaryFile'.)
+
hSetBinaryMode :: Handle -> Bool -> IO ()
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
foreign import ccall unsafe "__hscore_setmode"
setmode :: CInt -> Bool -> IO CInt
+-- -----------------------------------------------------------------------------
+-- Duplicating a Handle
+
+-- | 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)
+ newFileHandle path (handleFinalizer path) new_h_
+hDuplicate h@(DuplexHandle path r w) = do
+ new_w_ <- withHandle' "hDuplicate" h w (dupHandle Nothing)
+ new_w <- newMVar new_w_
+ new_r_ <- withHandle' "hDuplicate" h r (dupHandle (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
+ -- flush the buffer first, so we don't have to copy its contents
+ flushBuffer h_
+ new_fd <- throwErrnoIfMinus1 "dupHandle" $
+ c_dup (fromIntegral (haFD h_))
+ dupHandle_ other_side h_ new_fd
+
+dupHandleTo other_side hto_ h_ = do
+ flushBuffer h_
+ new_fd <- throwErrnoIfMinus1 "dupHandleTo" $
+ c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
+ dupHandle_ other_side h_ new_fd
+
+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,
+ haBuffer = ioref,
+ haBuffers = ioref_buffers,
+ haOtherSide = other_side }
+ return (h_, new_handle_)
+
+-- -----------------------------------------------------------------------------
+-- Replacing a Handle
+
+{- |
+Makes the second handle a duplicate of the first handle. The second
+handle will be closed first, if it is not already.
+
+This can be used to retarget the standard Handles, for example:
+
+> do h <- openFile "mystdout" WriteMode
+> hDuplicateTo h stdout
+-}
+
+hDuplicateTo :: Handle -> Handle -> IO ()
+hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
+ _ <- hClose_help h2_
+ 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 (dupHandleTo Nothing w2_)
+ withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
+ _ <- hClose_help r2_
+ withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_)
+hDuplicateTo h1 _ =
+ ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
+ "handles are incompatible" Nothing)
+
+-- ---------------------------------------------------------------------------
+-- showing Handles.
+--
+-- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
+-- than the (pure) instance of 'Show' for 'Handle'.
+
+hShow :: Handle -> IO String
+hShow h@(FileHandle path _) = showHandle' path False h
+hShow h@(DuplexHandle path _ _) = showHandle' path True h
+
+showHandle' filepath is_duplex h =
+ withHandle_ "showHandle" h $ \hdl_ ->
+ let
+ showType | is_duplex = showString "duplex (read-write)"
+ | otherwise = shows (haType hdl_)
+ in
+ return
+ (( showChar '{' .
+ showHdl (haType hdl_)
+ (showString "loc=" . showString filepath . showChar ',' .
+ showString "type=" . showType . showChar ',' .
+ showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
+ showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+ ) "")
+ where
+
+ showHdl :: HandleType -> ShowS -> ShowS
+ showHdl ht cont =
+ case ht of
+ ClosedHandle -> shows ht . showString "}"
+ _ -> cont
+
+ showBufMode :: Buffer -> BufferMode -> ShowS
+ showBufMode buf bmo =
+ case bmo of
+ NoBuffering -> showString "none"
+ LineBuffering -> showString "line"
+ BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
+ BlockBuffering Nothing -> showString "block " . showParen True (shows def)
+ where
+ def :: Int
+ def = bufSize buf
+
-- ---------------------------------------------------------------------------
-- debugging
-#ifdef DEBUG_DUMP
+#if defined(DEBUG_DUMP)
puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
- return ()
+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
+ return ()
#endif
-- -----------------------------------------------------------------------------
+-- utils
+
+throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt
+throwErrnoIfMinus1RetryOnBlock loc f on_block =
+ do
+ res <- f
+ if (res :: CInt) == -1
+ then do
+ err <- getErrno
+ if err == eINTR
+ then throwErrnoIfMinus1RetryOnBlock loc f on_block
+ else if err == eWOULDBLOCK || err == eAGAIN
+ then do on_block
+ else throwErrno loc
+ else return res
+
+-- -----------------------------------------------------------------------------
-- wrappers to platform-specific constants:
foreign import ccall unsafe "__hscore_supportsTextMode"
projects / haskell-directory.git / blobdiff