X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=e99c40ac935eead5af5bea1a22c6c20f8b3cc321;hb=HEAD;hp=fd06fc6a5b2898e59c359f2ae45e73fbb77c3c24;hpb=8dff2a318448b67a99627d54bbad1108010cb61e;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index fd06fc6..e99c40a 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,8 +1,4 @@ -{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} - -#undef DEBUG_DUMP -#undef DEBUG - +{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.Handle @@ -13,30 +9,32 @@ -- Stability : internal -- Portability : non-portable -- --- This module defines the basic operations on I\/O \"handles\". +-- Backwards-compatibility interface -- ----------------------------------------------------------------------------- -- #hide -module GHC.Handle ( + +module GHC.Handle {-# DEPRECATED "use GHC.IO.Handle instead" #-} ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, - - newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, - fillReadBuffer, fillReadBufferWithoutBlocking, - readRawBuffer, readRawBufferPtr, - writeRawBuffer, writeRawBufferPtr, -#ifndef mingw32_HOST_OS - unlockFile, -#endif +-- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, +-- flushWriteBufferOnly, flushWriteBuffer, +-- flushReadBuffer, +-- fillReadBuffer, fillReadBufferWithoutBlocking, +-- readRawBuffer, readRawBufferPtr, +-- readRawBufferNoBlock, readRawBufferPtrNoBlock, +-- writeRawBuffer, writeRawBufferPtr, ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle, - hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, + IOMode(..), openFile, openBinaryFile, +-- fdToHandle_stat, + fdToHandle, fdToHandle', + hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead_, + hSetBuffering, hSetBinaryMode, hFlush, hDuplicate, hDuplicateTo, hClose, hClose_help, @@ -49,1647 +47,9 @@ module GHC.Handle ( 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.Real - -import GHC.Arr -import GHC.Base -import GHC.Read ( Read ) -import GHC.List -import GHC.IOBase -import GHC.Exception -import GHC.Enum -import GHC.Num ( Integer(..), Num(..) ) -import GHC.Show -import GHC.Real ( toInteger ) -#if defined(DEBUG_DUMP) -import GHC.Pack -#endif - -import GHC.Conc - --- ----------------------------------------------------------------------------- --- TODO: - --- hWaitForInput blocks (should use a timeout) - --- unbuffered hGetLine is a bit dodgy - --- hSetBuffering: can't change buffering on a stream, --- when the read buffer is non-empty? (no way to flush the buffer) - --- --------------------------------------------------------------------------- --- Are files opened by default in text or binary mode, if the user doesn't --- specify? - -dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool - --- --------------------------------------------------------------------------- --- Creating a new handle - -newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle -newFileHandle filepath finalizer hc = do - m <- newMVar hc - addMVarFinalizer m (finalizer m) - return (FileHandle filepath m) - --- --------------------------------------------------------------------------- --- Working with Handles - -{- -In the concurrent world, handles are locked during use. This is done -by wrapping an MVar around the handle which acts as a mutex over -operations on the handle. - -To avoid races, we use the following bracketing operations. The idea -is to obtain the lock, do some operation and replace the lock again, -whether the operation succeeded or failed. We also want to handle the -case where the thread receives an exception while processing the IO -operation: in these cases we also want to relinquish the lock. - -There are three versions of @withHandle@: corresponding to the three -possible combinations of: - - - the operation may side-effect the handle - - the operation may return a result - -If the operation generates an error or an exception is raised, the -original handle is always replaced [ this is the case at the moment, -but we might want to revisit this in the future --SDM ]. --} - -{-# 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' :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - (h',v) <- catchException (act 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_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - v <- catchException (act 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 - withHandle__' fun h r act - withHandle__' fun h w act - -withHandle__' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - h' <- catchException (act h_) - (\ err -> putMVar m h_ >> - case err of - IOException ex -> ioError (augmentIOError ex fun h) - _ -> throw err) - checkBufferInvariants h' - putMVar m h' - return () - -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 m act -wantWritableHandle fun h@(DuplexHandle _ _ m) act - = wantWritableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkWritableHandle - -wantWritableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantWritableHandle' fun h m act - = withHandle_' fun h m (checkWritableHandle act) - -checkWritableHandle act handle_ - = case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - ReadHandle -> ioe_notWritable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - new_buf <- - if not (bufferIsWritable buf) - then do b <- flushReadBuffer (haFD handle_) buf - return b{ bufState=WriteBuffer } - else return buf - writeIORef ref new_buf - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for read operations. - -wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantReadableHandle fun h@(FileHandle _ m) act - = wantReadableHandle' fun h m act -wantReadableHandle fun h@(DuplexHandle _ m _) act - = wantReadableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkReadableHandle - -wantReadableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantReadableHandle' fun h m act - = withHandle_' fun h m (checkReadableHandle act) - -checkReadableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef ref new_buf{ bufState=ReadBuffer } - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for seek operations. - -wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantSeekableHandle fun h@(DuplexHandle _ _ _) _act = - ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing) -wantSeekableHandle fun h@(FileHandle _ m) act = - withHandle_' fun h m (checkSeekableHandle act) - -checkSeekableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notSeekable - _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_ - | otherwise -> ioe_notSeekable_notBin - --- ----------------------------------------------------------------------------- --- Handy IOErrors - -ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, - ioe_notSeekable, ioe_notSeekable_notBin :: IO a - -ioe_closedHandle = ioException - (IOError Nothing IllegalOperation "" - "handle is closed" Nothing) -ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing) -ioe_notReadable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing) -ioe_notWritable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing) -ioe_notSeekable = ioException - (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing) -ioe_notSeekable_notBin = ioException - (IOError Nothing IllegalOperation "" - "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" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing) - -- 9 => should be parens'ified. - --- ----------------------------------------------------------------------------- --- Handle Finalizers - --- For a duplex handle, we arrange that the read side points to the write side --- (and hence keeps it alive if the read side is alive). This is done by --- having the haOtherSide field of the read side point to the read side. --- The finalizer is then placed on the write side, and the handle only gets --- finalized once, when both sides are no longer required. - --- 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 :: 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 - -#ifdef DEBUG -checkBufferInvariants h_ = do - let ref = haBuffer h_ - Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref - if not ( - size > 0 - && r <= w - && w <= size - && ( r /= w || (r == 0 && w == 0) ) - && ( state /= WriteBuffer || r == 0 ) - && ( state /= WriteBuffer || w < size ) -- write buffer is never full - ) - then error "buffer invariant violation" - else return () -#else -checkBufferInvariants h_ = return () -#endif - -newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer -newEmptyBuffer b state size - = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state } - -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 -writeCharIntoBuffer slab (I# off) (C# c) - = IO $ \s -> case writeCharArray# slab off c s of - s -> (# s, I# (off +# 1#) #) - -readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int) -readCharFromBuffer slab (I# off) - = IO $ \s -> case readCharArray# slab off s of - (# s, c #) -> (# s, (C# c, I# (off +# 1#)) #) - -getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) -getBuffer fd state = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state - ioref <- newIORef buffer - is_tty <- fdIsTTY fd - - let buffer_mode - | is_tty = LineBuffering - | otherwise = BlockBuffering Nothing - - return (ioref, buffer_mode) - -mkUnBuffer :: IO (IORef Buffer) -mkUnBuffer = do - buffer <- allocateBuffer 1 ReadBuffer - newIORef buffer - --- flushWriteBufferOnly flushes the buffer iff it contains pending write data. -flushWriteBufferOnly :: Handle__ -> IO () -flushWriteBufferOnly h_ = do - let fd = haFD h_ - ref = haBuffer h_ - buf <- readIORef ref - new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd (haIsStream h_) buf - else return buf - writeIORef ref new_buf - --- flushBuffer syncs the file with the buffer, including moving the --- file pointer backwards in the case of a read buffer. -flushBuffer :: Handle__ -> IO () -flushBuffer h_ = do - let ref = haBuffer h_ - buf <- readIORef ref - - flushed_buf <- - case bufState buf of - ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) (haIsStream h_) buf - - writeIORef ref flushed_buf - --- When flushing a read buffer, we seek backwards by the number of --- characters in the buffer. The file descriptor must therefore be --- seekable: attempting to flush the read buffer on an unseekable --- handle is not allowed. - -flushReadBuffer :: FD -> Buffer -> IO Buffer -flushReadBuffer fd buf - | bufferEmpty buf = return buf - | otherwise = do - let off = negate (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") -# endif - throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek fd (fromIntegral off) sEEK_CUR) - return buf{ bufWPtr=0, bufRPtr=0 } - -flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer -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") -#endif - if bytes == 0 - then return (buf{ bufRPtr=0, bufWPtr=0 }) - else do - res <- writeRawBuffer "flushWriteBuffer" 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 } - -fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line is_stream - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line is_stream buf b w size - --- For a line buffer, we just get the first chunk of data to arrive, --- and don't wait for the whole buffer to be full (but we *do* wait --- until some data arrives). This isn't really line buffering, but it --- appears to be what GHC has done for a long time, and I suspect it --- is more useful than line buffering in most cases. - -fillReadBufferLoop fd is_line is_stream buf b w size = do - let bytes = size - w - if bytes == 0 -- buffer full? - then return buf{ bufRPtr=0, bufWPtr=w } - else do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") -#endif - res <- readRawBuffer "fillReadBuffer" fd is_stream b - (fromIntegral w) (fromIntegral bytes) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n") -#endif - if res' == 0 - then if w == 0 - then ioe_EOF - else return buf{ bufRPtr=0, bufWPtr=w } - else if res' < bytes && not is_line - 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 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 fd buf off len) - (threadWaitWrite (fromIntegral fd)) - -foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall unsafe "__hscore_PrelHandle_read" - 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_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 = 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 (fromIntegral 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 (fromIntegral 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 (fromIntegral 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 (fromIntegral 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 fd buf off len -blockingWriteRawBuffer loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - write_rawBuffer fd buf off len - -blockingWriteRawBufferPtr loc fd True buf off len = - throwErrnoIfMinus1Retry loc $ - send_off fd buf off len -blockingWriteRawBufferPtr loc fd False buf off len = - throwErrnoIfMinus1Retry loc $ - 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 :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_read" - read_off :: CInt -> 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 :: CInt -> RawBuffer -> Int -> CInt -> IO CInt - -foreign import ccall safe "__hscore_PrelHandle_recv" - recv_off :: CInt -> 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 - --- Three handles are allocated during program initialisation. The first --- two manage input or output from the Haskell program's standard input --- or output channel respectively. The third manages output to the --- standard error channel. These handles are initially open. - -fd_stdin = 0 :: FD -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 - setNonBlockingFD fd_stdin - (buf, bmode) <- getBuffer fd_stdin ReadBuffer - mkStdHandle fd_stdin "" ReadHandle buf bmode - --- | A handle managing output to the Haskell program's standard output channel. -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 - (buf, bmode) <- getBuffer fd_stdout WriteBuffer - mkStdHandle fd_stdout "" WriteHandle buf bmode - --- | A handle managing output to the Haskell program's standard error channel. -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 - buf <- mkUnBuffer - mkStdHandle fd_stderr "" WriteHandle buf NoBuffering - --- --------------------------------------------------------------------------- --- Opening and Closing Files - -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 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 True) - (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) - -openFile' filepath mode binary = - withCString filepath $ \ f -> - - let - oflags1 = case mode of - 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 - | binary = o_BINARY - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - in do - - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- 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 <- throwErrnoIfMinus1Retry "openFile" - (c_open f (fromIntegral oflags) 0o666) - - 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 `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 -rw_flags = output_flags .|. o_RDWR -append_flags = write_flags .|. o_APPEND - --- --------------------------------------------------------------------------- --- openFd - -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 - - let (ha_type, write) = - case mode of - ReadMode -> ( ReadHandle, False ) - WriteMode -> ( WriteHandle, True ) - ReadWriteMode -> ( ReadWriteHandle, True ) - AppendMode -> ( AppendHandle, True ) - - -- open() won't tell us if it was a directory if we only opened for - -- reading, so check again. - fd_type <- - case mb_fd_type of - Just x -> return x - Nothing -> fdType fd - - case fd_type of - Directory -> - ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing) - - -- regular files need to be locked - RegularFile -> do -#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_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_socket filepath binary - | otherwise -> - mkFileHandle fd is_socket filepath ha_type binary - - RawDevice -> - mkFileHandle fd is_socket filepath ha_type binary - -fdToHandle :: FD -> IO Handle -fdToHandle fd = do - mode <- fdGetMode fd - let fd_str = "" - 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 filepath) - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haIsStream = False, - haBufferMode = bmode, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -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 filepath) - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = bmode, - haBuffer = buf, - haBuffers = spares, - haOtherSide = Nothing - }) - -mkDuplexHandle :: FD -> Bool -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd is_stream filepath binary = do - (w_buf, w_bmode) <- getBuffer fd WriteBuffer - w_spares <- newIORef BufferListNil - let w_handle_ = - Handle__ { haFD = fd, - haType = WriteHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = w_bmode, - haBuffer = w_buf, - haBuffers = w_spares, - haOtherSide = Nothing - } - write_side <- newMVar w_handle_ - - (r_buf, r_bmode) <- getBuffer fd ReadBuffer - r_spares <- newIORef BufferListNil - let r_handle_ = - Handle__ { haFD = fd, - haType = ReadHandle, - haIsBin = binary, - haIsStream = is_stream, - haBufferMode = r_bmode, - haBuffer = r_buf, - haBuffers = r_spares, - haOtherSide = Just write_side - } - read_side <- newMVar r_handle_ - - addMVarFinalizer write_side (handleFinalizer filepath write_side) - return (DuplexHandle filepath read_side write_side) - - -initBufferState ReadHandle = ReadBuffer -initBufferState _ = WriteBuffer - --- --------------------------------------------------------------------------- --- Closing a handle - --- | 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 m = withHandle__' "hClose" h m $ hClose_help - --- hClose_help is also called by lazyRead (in PrelIO) when EOF is read --- or an IO error occurs on a lazy stream. The semi-closed Handle is --- then closed immediately. We have to be careful with DuplexHandles --- though: we have to leave the closing to the finalizer in that case, --- because the write side may still be in use. -hClose_help :: Handle__ -> IO Handle__ -hClose_help handle_ = - case haType handle_ of - ClosedHandle -> return handle_ - _ -> do flushWriteBufferOnly handle_ -- interruptible - hClose_handle_ handle_ - -hClose_handle_ handle_ = do - let fd = haFD handle_ - - -- 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_) fd) -#else - (c_close fd) -#endif - Just _ -> return () - - -- free the spare buffers - writeIORef (haBuffers handle_) BufferListNil - -#ifndef mingw32_HOST_OS - -- unlock it - 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, - haType = ClosedHandle - }) - ------------------------------------------------------------------------------ --- 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. - -hFileSize :: Handle -> IO Integer -hFileSize handle = - withHandle_ "hFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - r <- fdFileSize (haFD handle_) - if r /= -1 - then return r - 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 - --- | 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 ioError e) - --- | The computation 'isEOF' is identical to 'hIsEOF', --- except that it works only on 'stdin'. - -isEOF :: IO Bool -isEOF = hIsEOF stdin - --- --------------------------------------------------------------------------- --- Looking ahead - --- | 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 - wantReadableHandle "hLookAhead" handle $ \handle_ -> do - let ref = haBuffer handle_ - fd = haFD handle_ - is_line = haBufferMode handle_ == LineBuffering - buf <- readIORef ref - - -- fill up the read buffer if necessary - new_buf <- if bufferEmpty buf - then fillReadBuffer fd True (haIsStream handle_) buf - else return buf - - writeIORef ref new_buf - - (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf) - return c - --- --------------------------------------------------------------------------- --- Buffering Operations - --- Three kinds of buffering are supported: line-buffering, --- 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. --- --- If the buffer mode is changed from 'BlockBuffering' or --- 'LineBuffering' to 'NoBuffering', then --- --- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; --- --- * 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 = - withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> do - {- Note: - - we flush the old buffer regardless of whether - the new buffer could fit the contents of the old buffer - or not. - - allow a handle's buffering to change even if IO has - occurred (ANSI C spec. does not allow this, nor did - the previous implementation of IO.hSetBuffering). - - a non-standard extension is to allow the buffering - of semi-closed handles to change [sof 6/98] - -} - flushBuffer handle_ - - let state = initBufferState (haType handle_) - new_buf <- - case mode of - -- we always have a 1-character read buffer for - -- unbuffered handles: it's needed to - -- support hLookAhead. - NoBuffering -> allocateBuffer 1 ReadBuffer - LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n - | otherwise -> allocateBuffer n state - writeIORef (haBuffer handle_) new_buf - - -- for input terminals we need to put the terminal into - -- cooked or raw mode depending on the type of buffering. - 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 - writeIORef (haBuffers handle_) BufferListNil - - return (handle_{ haBufferMode = mode }) - --- ----------------------------------------------------------------------------- --- hFlush - --- | 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 = - wantWritableHandle "hFlush" handle $ \ handle_ -> do - buf <- readIORef (haBuffer handle_) - if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) buf - writeIORef (haBuffer handle_) flushed_buf - else return () - - --- ----------------------------------------------------------------------------- --- Repositioning Handles - -data HandlePosn = HandlePosn Handle HandlePosition - -instance Eq HandlePosn where - (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 - -instance Show HandlePosn where - showsPrec p (HandlePosn h pos) = - showsPrec p h . showString " at position " . shows pos - - -- HandlePosition is the Haskell equivalent of POSIX' off_t. - -- We represent it as an Integer on the Haskell side, but - -- cheat slightly in that hGetPosn calls upon a C helper - -- that reports the position back via (merely) an Int. -type HandlePosition = Integer - --- | 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 - --- | 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: - - when seeking using `SeekFromEnd', positive offsets (>=0) means - seeking at or past EOF. - - - we possibly deviate from the report on the issue of seeking within - the buffer and whether to flush it or not. The report isn't exactly - clear here. --} - --- | 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 = - wantSeekableHandle "hSeek" handle $ \ handle_ -> do -# ifdef DEBUG_DUMP - puts ("hSeek " ++ show (mode,offset) ++ "\n") -# endif - let ref = haBuffer handle_ - buf <- readIORef ref - let r = bufRPtr buf - w = bufWPtr buf - fd = haFD handle_ - - let do_seek = - throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (haFD handle_) (fromIntegral offset) whence) - - whence :: CInt - whence = case mode of - AbsoluteSeek -> sEEK_SET - RelativeSeek -> sEEK_CUR - SeekFromEnd -> sEEK_END - - if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd (haIsStream handle_) buf - writeIORef ref new_buf - do_seek - else do - - if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r) - then writeIORef ref buf{ bufRPtr = r + fromIntegral offset } - else do - - new_buf <- flushReadBuffer (haFD handle_) buf - writeIORef ref new_buf - do_seek - - -hTell :: Handle -> IO Integer -hTell handle = - wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - -#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 = haFD handle_ - posn <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 sEEK_CUR) - - let ref = haBuffer handle_ - buf <- readIORef ref - - let real_posn - | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) - | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") - puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") -# endif - return real_posn - --- ----------------------------------------------------------------------------- --- Handle Properties - --- A number of operations return information about the properties of a --- handle. Each of these operations returns `True' if the handle has --- the specified property, and `False' otherwise. - -hIsOpen :: Handle -> IO Bool -hIsOpen handle = - withHandle_ "hIsOpen" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return False - SemiClosedHandle -> return False - _ -> return True - -hIsClosed :: Handle -> IO Bool -hIsClosed handle = - withHandle_ "hIsClosed" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return True - _ -> return False - -{- not defined, nor exported, but mentioned - here for documentation purposes: - - hSemiClosed :: Handle -> IO Bool - hSemiClosed h = do - ho <- hIsOpen h - hc <- hIsClosed h - return (not (ho || hc)) --} - -hIsReadable :: Handle -> IO Bool -hIsReadable (DuplexHandle _ _ _) = return True -hIsReadable handle = - withHandle_ "hIsReadable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isReadableHandleType htype) - -hIsWritable :: Handle -> IO Bool -hIsWritable (DuplexHandle _ _ _) = return True -hIsWritable handle = - withHandle_ "hIsWritable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isWritableHandleType htype) - --- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode --- for @hdl@. - -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering handle = - withHandle_ "hGetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> - -- We're being non-standard here, and allow the buffering - -- of a semi-closed handle to be queried. -- sof 6/98 - return (haBufferMode handle_) -- could be stricter.. - -hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = - withHandle_ "hIsSeekable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> return False - _ -> do t <- fdType (haFD handle_) - return ((t == RegularFile || t == RawDevice) - && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) - --- ----------------------------------------------------------------------------- --- Changing echo status (Non-standard GHC extensions) - --- | Set the echoing status of a handle connected to a terminal. - -hSetEcho :: Handle -> Bool -> IO () -hSetEcho handle on = do - isT <- hIsTerminalDevice handle - if not isT - then return () - else - withHandle_ "hSetEcho" handle $ \ handle_ -> do - case haType handle_ of - 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 - if not isT - then return False - else - withHandle_ "hGetEcho" handle $ \ handle_ -> do - case haType handle_ of - 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 - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> fdIsTTY (haFD handle_) - --- ----------------------------------------------------------------------------- --- 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_ -> - do throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (haFD handle_) bin) - return handle_{haIsBin=bin} - -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 h Nothing) - newFileHandle path (handleFinalizer path) new_h_ -hDuplicate h@(DuplexHandle path r w) = do - new_w_ <- withHandle' "hDuplicate" h w (dupHandle h Nothing) - new_w <- newMVar 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 :: 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 <- 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 = 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 - -#if defined(DEBUG_DUMP) -puts :: String -> IO () -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" - tEXT_MODE_SEEK_ALLOWED :: Bool - -foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int -foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt -foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt -foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt +import GHC.IO.IOMode +import GHC.IO.Handle +import GHC.IO.Handle.Internals +import GHC.IO.Handle.FD