+++ /dev/null
-{-# OPTIONS -fno-implicit-prelude #-}
-
-#undef DEBUG_DUMP
-#undef DEBUG
-
--- -----------------------------------------------------------------------------
--- $Id: PrelHandle.hsc,v 1.17 2001/10/16 15:06:38 simonmar Exp $
---
--- (c) The University of Glasgow, 1994-2001
---
--- This module defines the basic operations on I/O "handles".
-
-module PrelHandle (
- withHandle, withHandle', withHandle_,
- wantWritableHandle, wantReadableHandle, wantSeekableHandle,
-
- newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
- flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
- read_off,
-
- ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
-
- stdin, stdout, stderr,
- IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
- hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
- hFlush,
-
- hClose, hClose_help,
-
- HandlePosn(..), hGetPosn, hSetPosn,
- SeekMode(..), hSeek,
-
- hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
- hSetEcho, hGetEcho, hIsTerminalDevice,
- ioeGetFileName, ioeGetErrorString, ioeGetHandle,
-
-#ifdef DEBUG_DUMP
- puts,
-#endif
-
- ) where
-
-#include "HsStd.h"
-
-import Monad
-
-import PrelBits
-import PrelPosix
-import PrelMarshalUtils
-import PrelCString
-import PrelCTypes
-import PrelCError
-import PrelReal
-
-import PrelArr
-import PrelBase
-import PrelPtr
-import PrelRead ( Read )
-import PrelList
-import PrelIOBase
-import PrelMaybe ( Maybe(..) )
-import PrelException
-import PrelEnum
-import PrelNum ( Integer(..), Num(..) )
-import PrelShow
-import PrelReal ( toInteger )
-
-import PrelConc
-
--- -----------------------------------------------------------------------------
--- 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 :: Bool
-dEFAULT_OPEN_IN_BINARY_MODE = False
-
--- Is seeking on text-mode handles allowed, or not?
-tEXT_MODE_SEEK_ALLOWED :: Bool
-#if defined(mingw32_TARGET_OS)
-tEXT_MODE_SEEK_ALLOWED = False
-#else
-tEXT_MODE_SEEK_ALLOWED = True
-#endif
-
-
--- ---------------------------------------------------------------------------
--- Creating a new handle
-
-newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle finalizer hc = do
- m <- newMVar hc
- addMVarFinalizer m (finalizer m)
- return (FileHandle 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' fun h m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- (h',v) <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
- 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 m act =
- block $ do
- h_ <- takeMVar m
- checkBufferInvariants h_
- v <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
- 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_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
- 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
-
--- ---------------------------------------------------------------------------
--- 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_) 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_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 haType field of the read side be ReadSideHandle with a pointer
--- to the write side. The finalizer is then placed on the write side, and
--- the handle only gets finalized once, when both sides are no longer
--- required.
-
-addFinalizer :: Handle -> IO ()
-addFinalizer (FileHandle m) = addMVarFinalizer m (handleFinalizer m)
-addFinalizer (DuplexHandle _ w) = addMVarFinalizer w (handleFinalizer w)
-
-stdHandleFinalizer :: MVar Handle__ -> IO ()
-stdHandleFinalizer m = do
- h_ <- takeMVar m
- flushWriteBufferOnly h_
-
-handleFinalizer :: MVar Handle__ -> IO ()
-handleFinalizer m = do
- h_ <- takeMVar m
- flushWriteBufferOnly h_
- let fd = fromIntegral (haFD h_)
- unlockFile fd
- -- ToDo: closesocket() for a WINSOCK socket?
- when (fd /= -1) (c_close fd >> return ())
- return ()
-
--- ---------------------------------------------------------------------------
--- 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 ->
- case newByteArray## size s of { (## s, b ##) ->
- (## 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##)) ##)
-
-dEFAULT_BUFFER_SIZE = (#const BUFSIZ) :: Int
-
-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 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_) 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 (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR))
- return buf{ bufWPtr=0, bufRPtr=0 }
-
-flushWriteBuffer :: FD -> Buffer -> IO Buffer
-flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do
- 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 <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
- (write_off (fromIntegral fd) b (fromIntegral r)
- (fromIntegral bytes))
- (threadWaitWrite fd)
- let res' = fromIntegral res
- if res' < bytes
- then flushWriteBuffer fd (buf{ bufRPtr = r + res' })
- else return buf{ bufRPtr=0, bufWPtr=0 }
-
-foreign import "write_PrelHandle_wrap" unsafe
- write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
-#def inline \
-int write_PrelHandle_wrap(int fd, void *ptr, HsInt off, int size) \
-{ return write(fd, ptr + off, size); }
-
-
-fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer
-fillReadBuffer fd is_line
- buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
- -- buffer better be empty:
- assert (r == 0 && w == 0) $ do
- fillReadBufferLoop fd is_line 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 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 <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
- (read_off fd b (fromIntegral w) (fromIntegral bytes))
- (threadWaitRead fd)
- 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 buf b (w+res') size
- else return buf{ bufRPtr=0, bufWPtr=w+res' }
-
-foreign import "read_PrelHandle_wrap" unsafe
- read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt
-#def inline \
-int read_PrelHandle_wrap(int fd, void *ptr, HsInt off, int size) \
-{ return read(fd, ptr + off, size); }
-
--- ---------------------------------------------------------------------------
--- 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
-
-stdin :: Handle
-stdin = unsafePerformIO $ do
- -- ToDo: acquire lock
- setNonBlockingFD fd_stdin
- (buf, bmode) <- getBuffer fd_stdin ReadBuffer
- spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
- (Handle__ { haFD = fd_stdin,
- haType = ReadHandle,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haBufferMode = bmode,
- haFilePath = "<stdin>",
- haBuffer = buf,
- haBuffers = spares
- })
-
-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
- spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
- (Handle__ { haFD = fd_stdout,
- haType = WriteHandle,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haBufferMode = bmode,
- haFilePath = "<stdout>",
- haBuffer = buf,
- haBuffers = spares
- })
-
-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
- buffer <- mkUnBuffer
- spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
- (Handle__ { haFD = fd_stderr,
- haType = WriteHandle,
- haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
- haBufferMode = NoBuffering,
- haFilePath = "<stderr>",
- haBuffer = buffer,
- haBuffers = spares
- })
-
--- ---------------------------------------------------------------------------
--- 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
-
-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 =
- catch
- (openFile' fp m)
- (\e -> throw (addFilePathToIOError "openFileEx" fp e))
-
-
-openFile' filepath ex_mode =
- 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
- AppendMode -> append_flags
-
- truncate | WriteMode <- mode = True
- | otherwise = False
-
- binary_flags
-#ifdef HAVE_O_BINARY
- | binary = o_BINARY
-#endif
- | 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 <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "openFile"
- (c_open f (fromIntegral oflags) 0o666)
-
- openFd fd filepath mode binary truncate
- -- 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).
-
-
-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 -> FilePath -> IOMode -> Bool -> Bool -> IO Handle
-openFd fd filepath mode binary truncate = 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 <- fdType fd
- case fd_type of
- Directory ->
- ioException (IOError Nothing InappropriateType "openFile"
- "is a directory" Nothing)
-
- Stream
- | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary
- | otherwise -> mkFileHandle fd filepath ha_type binary
-
- -- regular files need to be locked
- RegularFile -> do
- r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
- when (r == -1) $
- ioException (IOError Nothing ResourceBusy "openFile"
- "file is locked" Nothing)
-
- -- truncate the file if necessary
- when truncate (fileTruncate filepath)
-
- mkFileHandle fd filepath ha_type binary
-
-
-foreign import "lockFile" unsafe
- lockFile :: CInt -> CInt -> CInt -> IO CInt
-
-foreign import "unlockFile" unsafe
- unlockFile :: CInt -> IO CInt
-
-mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle
-mkFileHandle fd filepath ha_type binary = do
- (buf, bmode) <- getBuffer fd (initBufferState ha_type)
- spares <- newIORef BufferListNil
- newFileHandle handleFinalizer
- (Handle__ { haFD = fd,
- haType = ha_type,
- haIsBin = binary,
- haBufferMode = bmode,
- haFilePath = filepath,
- haBuffer = buf,
- haBuffers = spares
- })
-
-mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle
-mkDuplexHandle fd filepath binary = do
- (w_buf, w_bmode) <- getBuffer fd WriteBuffer
- w_spares <- newIORef BufferListNil
- let w_handle_ =
- Handle__ { haFD = fd,
- haType = WriteHandle,
- haIsBin = binary,
- haBufferMode = w_bmode,
- haFilePath = filepath,
- haBuffer = w_buf,
- haBuffers = w_spares
- }
- write_side <- newMVar w_handle_
-
- (r_buf, r_bmode) <- getBuffer fd ReadBuffer
- r_spares <- newIORef BufferListNil
- let r_handle_ =
- Handle__ { haFD = fd,
- haType = ReadSideHandle write_side,
- haIsBin = binary,
- haBufferMode = r_bmode,
- haFilePath = filepath,
- haBuffer = r_buf,
- haBuffers = r_spares
- }
- read_side <- newMVar r_handle_
-
- addMVarFinalizer write_side (handleFinalizer write_side)
- return (DuplexHandle read_side write_side)
-
-
-initBufferState ReadHandle = ReadBuffer
-initBufferState _ = WriteBuffer
-
--- ---------------------------------------------------------------------------
--- 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.
-
-hClose :: Handle -> IO ()
-hClose h@(FileHandle m) = hClose' h m
-hClose h@(DuplexHandle r w) = do
- hClose' h w
- withHandle__' "hClose" h r $ \ handle_ -> do
- return handle_{ haFD = -1,
- haType = ClosedHandle
- }
-
-hClose' h m = withHandle__' "hClose" h m $ hClose_help
-
-hClose_help handle_ =
- case haType handle_ of
- ClosedHandle -> return handle_
- _ -> do
- let fd = fromIntegral (haFD handle_)
- flushWriteBufferOnly handle_
- throwErrnoIfMinus1Retry_ "hClose" (c_close fd)
-
- -- free the spare buffers
- writeIORef (haBuffers handle_) BufferListNil
-
- -- unlock it
- unlockFile fd
-
- -- 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
-
--- 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'.
-
-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)
-
--- ---------------------------------------------------------------------------
--- 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 throw e)
-
-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.
-
-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 is_line 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 PrelIOBase 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 mode is LineBuffering, line-buffering should be enabled if possible.
---
--- * 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 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.
-
-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
- NoBuffering -> setCooked (haFD handle_) False
- _ -> 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.
-
-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_) 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 an abstract position. Computation `hSetPosn p' sets the
--- position of `hdl' to a previously obtained position `p'.
-
-hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle =
- wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
-
-#if defined(_WIN32)
- -- urgh, on Windows we have to worry about \n -> \r\n translation,
- -- so we can't easily calculate the file position using the
- -- current buffer size. Just flush instead.
- flushBuffer handle_
-#endif
- let fd = fromIntegral (haFD handle_)
- posn <- fromIntegral `liftM`
- throwErrnoIfMinus1Retry "hGetPosn"
- (c_lseek fd 0 (#const 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 (HandlePosn handle real_posn)
-
-
-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.
-
-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.
--}
-
-data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-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 (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
-
- whence :: CInt
- whence = case mode of
- AbsoluteSeek -> (#const SEEK_SET)
- RelativeSeek -> (#const SEEK_CUR)
- SeekFromEnd -> (#const SEEK_END)
-
- if bufferIsWritable buf
- then do new_buf <- flushWriteBuffer fd 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
-
--- -----------------------------------------------------------------------------
--- 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 False
-hIsWritable handle =
- withHandle_ "hIsWritable" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- htype -> return (isWritableHandleType htype)
-
--- Querying how a handle buffers its data:
-
-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
- && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED))
-
--- -----------------------------------------------------------------------------
--- Changing echo status
-
--- Non-standard GHC extension is to allow the echoing status
--- of a handles connected to terminals to be reconfigured:
-
-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
-
-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_)
-
-hIsTerminalDevice :: Handle -> IO Bool
-hIsTerminalDevice handle = do
- withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- _ -> fdIsTTY (haFD handle_)
-
--- -----------------------------------------------------------------------------
--- hSetBinaryMode
-
-#ifdef _WIN32
-hSetBinaryMode handle bin =
- withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
- do let flg | bin = (#const O_BINARY)
- | otherwise = (#const O_TEXT)
- throwErrnoIfMinus1_ "hSetBinaryMode"
- (setmode (fromIntegral (haFD handle_)) flg)
- return handle_{haIsBin=bin}
-
-foreign import "setmode" setmode :: CInt -> CInt -> IO CInt
-#else
-hSetBinaryMode handle bin =
- withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
- return handle_{haIsBin=bin}
-#endif
-
--- -----------------------------------------------------------------------------
--- Miscellaneous
-
--- These three functions are meant to get things out of an IOError.
-
-ioeGetFileName :: IOError -> Maybe FilePath
-ioeGetErrorString :: IOError -> String
-ioeGetHandle :: IOError -> Maybe Handle
-
-ioeGetHandle (IOException (IOError h _ _ _ _)) = h
-ioeGetHandle (UserError _) = Nothing
-ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
-
-ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
-ioeGetErrorString (UserError str) = str
-ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
-
-ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
-ioeGetFileName (UserError _) = Nothing
-ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
-
--- ---------------------------------------------------------------------------
--- debugging
-
-#ifdef DEBUG_DUMP
-puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s))
- return ()
-#endif
+++ /dev/null
-{-# OPTIONS -fno-implicit-prelude #-}
-
-#undef DEBUG_DUMP
-
--- -----------------------------------------------------------------------------
--- $Id: PrelIO.hsc,v 1.16 2001/09/18 08:32:11 simonmar Exp $
---
--- (c) The University of Glasgow, 1992-2001
---
--- Module PrelIO
-
--- This module defines all basic IO operations.
--- These are needed for the IO operations exported by Prelude,
--- but as it happens they also do everything required by library
--- module IO.
-
-module PrelIO (
- putChar, putStr, putStrLn, print, getChar, getLine, getContents,
- interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
- hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
- hPutStrLn, hPrint,
- commitBuffer', -- hack, see below
- hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
- ) where
-
-#include "HsStd.h"
-#include "PrelHandle_hsc.h"
-
-import PrelBase
-
-import PrelPosix
-import PrelMarshalUtils
-import PrelStorable
-import PrelCError
-import PrelCString
-import PrelCTypes
-import PrelCTypesISO
-
-import PrelIOBase
-import PrelHandle -- much of the real stuff is in here
-
-import PrelMaybe
-import PrelReal
-import PrelNum
-import PrelRead
-import PrelShow
-import PrelMaybe ( Maybe(..) )
-import PrelPtr
-import PrelList
-import PrelException ( ioError, catch, throw )
-import PrelConc
-
--- -----------------------------------------------------------------------------
--- Standard IO
-
-putChar :: Char -> IO ()
-putChar c = hPutChar stdout c
-
-putStr :: String -> IO ()
-putStr s = hPutStr stdout s
-
-putStrLn :: String -> IO ()
-putStrLn s = do putStr s
- putChar '\n'
-
-print :: Show a => a -> IO ()
-print x = putStrLn (show x)
-
-getChar :: IO Char
-getChar = hGetChar stdin
-
-getLine :: IO String
-getLine = hGetLine stdin
-
-getContents :: IO String
-getContents = hGetContents stdin
-
-interact :: (String -> String) -> IO ()
-interact f = do s <- getContents
- putStr (f s)
-
-readFile :: FilePath -> IO String
-readFile name = openFile name ReadMode >>= hGetContents
-
-writeFile :: FilePath -> String -> IO ()
-writeFile name str = do
- hdl <- openFile name WriteMode
- hPutStr hdl str
- hClose hdl
-
-appendFile :: FilePath -> String -> IO ()
-appendFile name str = do
- hdl <- openFile name AppendMode
- hPutStr hdl str
- hClose hdl
-
-readLn :: Read a => IO a
-readLn = do l <- getLine
- r <- readIO l
- return r
-
- -- raises an exception instead of an error
-readIO :: Read a => String -> IO a
-readIO s = case (do { (x,t) <- reads s ;
- ("","") <- lex t ;
- return x }) of
-#ifndef NEW_READS_REP
- [x] -> return x
- [] -> ioError (userError "Prelude.readIO: no parse")
- _ -> ioError (userError "Prelude.readIO: ambiguous parse")
-#else
- Just x -> return x
- Nothing -> ioError (userError "Prelude.readIO: no parse")
-#endif
-
--- ---------------------------------------------------------------------------
--- Simple input operations
-
--- Computation "hReady hdl" indicates whether at least
--- one item is available for input from handle "hdl".
-
--- If hWaitForInput finds anything in the Handle's buffer, it
--- immediately returns. If not, it tries to read from the underlying
--- OS handle. Notice that for buffered Handles connected to terminals
--- this means waiting until a complete line is available.
-
-hReady :: Handle -> IO Bool
-hReady h = hWaitForInput h 0
-
-hWaitForInput :: Handle -> Int -> IO Bool
-hWaitForInput h msecs = do
- wantReadableHandle "hReady" h $ \ handle_ -> do
- let ref = haBuffer handle_
- buf <- readIORef ref
-
- if not (bufferEmpty buf)
- then return True
- else do
-
- r <- throwErrnoIfMinus1Retry "hReady"
- (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs))
- return (r /= 0)
-
-foreign import "inputReady"
- inputReady :: CInt -> CInt -> IO CInt
-
--- ---------------------------------------------------------------------------
--- hGetChar
-
--- hGetChar reads the next character from a handle,
--- blocking until a character is available.
-
-hGetChar :: Handle -> IO Char
-hGetChar handle =
- wantReadableHandle "hGetChar" handle $ \handle_ -> do
-
- let fd = haFD handle_
- ref = haBuffer handle_
-
- buf <- readIORef ref
- if not (bufferEmpty buf)
- then hGetcBuffered fd ref buf
- else do
-
- -- buffer is empty.
- case haBufferMode handle_ of
- LineBuffering -> do
- new_buf <- fillReadBuffer fd True buf
- hGetcBuffered fd ref new_buf
- BlockBuffering _ -> do
- new_buf <- fillReadBuffer fd False buf
- hGetcBuffered fd ref new_buf
- NoBuffering -> do
- -- make use of the minimal buffer we already have
- let raw = bufBuf buf
- r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
- (read_off (fromIntegral fd) raw 0 1)
- (threadWaitRead fd)
- if r == 0
- then ioe_EOF
- else do (c,_) <- readCharFromBuffer raw 0
- return c
-
-hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }
- = do (c,r) <- readCharFromBuffer b r
- let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 }
- | otherwise = buf{ bufRPtr=r }
- writeIORef ref new_buf
- return c
-
--- ---------------------------------------------------------------------------
--- hGetLine
-
--- If EOF is reached before EOL is encountered, ignore the EOF and
--- return the partial line. Next attempt at calling hGetLine on the
--- handle will yield an EOF IO exception though.
-
--- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
--- the duration.
-hGetLine :: Handle -> IO String
-hGetLine h = do
- m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do
- case haBufferMode handle_ of
- NoBuffering -> return Nothing
- LineBuffering -> do
- l <- hGetLineBuffered handle_
- return (Just l)
- BlockBuffering _ -> do
- l <- hGetLineBuffered handle_
- return (Just l)
- case m of
- Nothing -> hGetLineUnBuffered h
- Just l -> return l
-
-
-hGetLineBuffered handle_ = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- hGetLineBufferedLoop handle_ ref buf []
-
-
-hGetLineBufferedLoop handle_ ref
- buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss =
- let
- -- find the end-of-line character, if there is one
- loop raw r
- | r == w = return (False, w)
- | otherwise = do
- (c,r') <- readCharFromBuffer raw r
- if c == '\n'
- then return (True, r) -- NB. not r': don't include the '\n'
- else loop raw r'
- in do
- (eol, off) <- loop raw r
-
-#ifdef DEBUG_DUMP
- puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n")
-#endif
-
- xs <- unpack raw r off
- if eol
- then do if w == off + 1
- then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- else writeIORef ref buf{ bufRPtr = off + 1 }
- return (concat (reverse (xs:xss)))
- else do
- maybe_buf <- maybeFillReadBuffer (haFD handle_) True
- buf{ bufWPtr=0, bufRPtr=0 }
- case maybe_buf of
- -- Nothing indicates we caught an EOF, and we may have a
- -- partial line to return.
- Nothing -> let str = concat (reverse (xs:xss)) in
- if not (null str)
- then return str
- else ioe_EOF
- Just new_buf ->
- hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
-
-
-maybeFillReadBuffer fd is_line buf
- = catch
- (do buf <- fillReadBuffer fd is_line buf
- return (Just buf)
- )
- (\e -> do if isEOFError e
- then return Nothing
- else throw e)
-
-
-unpack :: RawBuffer -> Int -> Int -> IO [Char]
-unpack buf r 0 = return ""
-unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
- where
- unpack acc i s
- | i <## r = (## s, acc ##)
- | otherwise =
- case readCharArray## buf i s of
- (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
-
-
-hGetLineUnBuffered :: Handle -> IO String
-hGetLineUnBuffered h = do
- c <- hGetChar h
- if c == '\n' then
- return ""
- else do
- l <- getRest
- return (c:l)
- where
- getRest = do
- c <-
- catch
- (hGetChar h)
- (\ err -> do
- if isEOFError err then
- return '\n'
- else
- ioError err)
- if c == '\n' then
- return ""
- else do
- s <- getRest
- return (c:s)
-
--- -----------------------------------------------------------------------------
--- hGetContents
-
--- hGetContents returns the list of characters corresponding to the
--- unread portion of the channel or file managed by the handle, which
--- is made semi-closed.
-
--- hGetContents on a DuplexHandle only affects the read side: you can
--- carry on writing to it afterwards.
-
-hGetContents :: Handle -> IO String
-hGetContents handle =
- withHandle "hGetContents" handle $ \handle_ ->
- case haType handle_ of
- ClosedHandle -> ioe_closedHandle
- SemiClosedHandle -> ioe_closedHandle
- AppendHandle -> ioe_notReadable
- WriteHandle -> ioe_notReadable
- _ -> do xs <- lazyRead handle
- return (handle_{ haType=SemiClosedHandle}, xs )
-
--- Note that someone may close the semi-closed handle (or change its
--- buffering), so each time these lazy read functions are pulled on,
--- they have to check whether the handle has indeed been closed.
-
-lazyRead :: Handle -> IO String
-lazyRead handle =
- unsafeInterleaveIO $
- withHandle "lazyRead" handle $ \ handle_ -> do
- case haType handle_ of
- ClosedHandle -> return (handle_, "")
- SemiClosedHandle -> lazyRead' handle handle_
- _ -> ioException
- (IOError (Just handle) IllegalOperation "lazyRead"
- "illegal handle type" Nothing)
-
-lazyRead' h handle_ = do
- let ref = haBuffer handle_
- fd = haFD handle_
-
- -- even a NoBuffering handle can have a char in the buffer...
- -- (see hLookAhead)
- buf <- readIORef ref
- if not (bufferEmpty buf)
- then lazyReadHaveBuffer h handle_ fd ref buf
- else do
-
- case haBufferMode handle_ of
- NoBuffering -> do
- -- make use of the minimal buffer we already have
- let raw = bufBuf buf
- fd = haFD handle_
- r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
- (read_off (fromIntegral fd) raw 0 1)
- (threadWaitRead fd)
- if r == 0
- then do handle_ <- hClose_help handle_
- return (handle_, "")
- else do (c,_) <- readCharFromBuffer raw 0
- rest <- lazyRead h
- return (handle_, c : rest)
-
- LineBuffering -> lazyReadBuffered h handle_ fd ref buf
- BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
-
--- we never want to block during the read, so we call fillReadBuffer with
--- is_line==True, which tells it to "just read what there is".
-lazyReadBuffered h handle_ fd ref buf = do
- catch
- (do buf <- fillReadBuffer fd True{-is_line-} buf
- lazyReadHaveBuffer h handle_ fd ref buf
- )
- -- all I/O errors are discarded. Additionally, we close the handle.
- (\e -> do handle_ <- hClose_help handle_
- return (handle_, "")
- )
-
-lazyReadHaveBuffer h handle_ fd ref buf = do
- more <- lazyRead h
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
- return (handle_, s)
-
-
-unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-unpackAcc buf r 0 acc = return ""
-unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s
- where
- unpack acc i s
- | i <## r = (## s, acc ##)
- | otherwise =
- case readCharArray## buf i s of
- (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s
-
--- ---------------------------------------------------------------------------
--- hPutChar
-
--- `hPutChar hdl ch' writes the character `ch' to the file or channel
--- managed by `hdl'. Characters may be buffered if buffering is
--- enabled for `hdl'.
-
-hPutChar :: Handle -> Char -> IO ()
-hPutChar handle c =
- c `seq` do -- must evaluate c before grabbing the handle lock
- wantWritableHandle "hPutChar" handle $ \ handle_ -> do
- let fd = haFD handle_
- case haBufferMode handle_ of
- LineBuffering -> hPutcBuffered handle_ True c
- BlockBuffering _ -> hPutcBuffered handle_ False c
- NoBuffering ->
- withObject (castCharToCChar c) $ \buf ->
- throwErrnoIfMinus1RetryMayBlock_ "hPutChar"
- (c_write (fromIntegral fd) buf 1)
- (threadWaitWrite fd)
-
-
-hPutcBuffered handle_ is_line c = do
- let ref = haBuffer handle_
- buf <- readIORef ref
- let w = bufWPtr buf
- w' <- writeCharIntoBuffer (bufBuf buf) w c
- let new_buf = buf{ bufWPtr = w' }
- if bufferFull new_buf || is_line && c == '\n'
- then do
- flushed_buf <- flushWriteBuffer (haFD handle_) new_buf
- writeIORef ref flushed_buf
- else do
- writeIORef ref new_buf
-
-
-hPutChars :: Handle -> [Char] -> IO ()
-hPutChars handle [] = return ()
-hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
-
--- ---------------------------------------------------------------------------
--- hPutStr
-
--- `hPutStr hdl s' writes the string `s' to the file or
--- hannel managed by `hdl', buffering the output if needs be.
-
--- We go to some trouble to avoid keeping the handle locked while we're
--- evaluating the string argument to hPutStr, in case doing so triggers another
--- I/O operation on the same handle which would lead to deadlock. The classic
--- case is
---
--- putStr (trace "hello" "world")
---
--- so the basic scheme is this:
---
--- * copy the string into a fresh buffer,
--- * "commit" the buffer to the handle.
---
--- Committing may involve simply copying the contents of the new
--- buffer into the handle's buffer, flushing one or both buffers, or
--- maybe just swapping the buffers over (if the handle's buffer was
--- empty). See commitBuffer below.
-
-hPutStr :: Handle -> String -> IO ()
-hPutStr handle str = do
- buffer_mode <- wantWritableHandle "hPutStr" handle
- (\ handle_ -> do getSpareBuffer handle_)
- case buffer_mode of
- (NoBuffering, _) -> do
- hPutChars handle str -- v. slow, but we don't care
- (LineBuffering, buf) -> do
- writeLines handle buf str
- (BlockBuffering _, buf) -> do
- writeBlocks handle buf str
-
-
-getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer)
-getSpareBuffer Handle__{haBuffer=ref,
- haBuffers=spare_ref,
- haBufferMode=mode}
- = do
- case mode of
- NoBuffering -> return (mode, error "no buffer!")
- _ -> do
- bufs <- readIORef spare_ref
- buf <- readIORef ref
- case bufs of
- BufferListCons b rest -> do
- writeIORef spare_ref rest
- return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf))
- BufferListNil -> do
- new_buf <- allocateBuffer (bufSize buf) WriteBuffer
- return (mode, new_buf)
-
-
-writeLines :: Handle -> Buffer -> String -> IO ()
-writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s =
- let
- shoveString :: Int -> [Char] -> IO ()
- -- check n == len first, to ensure that shoveString is strict in n.
- shoveString n cs | n == len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeLines hdl new_buf cs
- shoveString n [] = do
- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- if (c == '\n')
- then do
- new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
- writeLines hdl new_buf cs
- else
- shoveString n' cs
- in
- shoveString 0 s
-
-writeBlocks :: Handle -> Buffer -> String -> IO ()
-writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s =
- let
- shoveString :: Int -> [Char] -> IO ()
- -- check n == len first, to ensure that shoveString is strict in n.
- shoveString n cs | n == len = do
- new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeBlocks hdl new_buf cs
- shoveString n [] = do
- commitBuffer hdl raw len n False{-no flush-} True{-release-}
- return ()
- shoveString n (c:cs) = do
- n' <- writeCharIntoBuffer raw n c
- shoveString n' cs
- in
- shoveString 0 s
-
--- -----------------------------------------------------------------------------
--- commitBuffer handle buf sz count flush release
---
--- Write the contents of the buffer 'buf' ('sz' bytes long, containing
--- 'count' bytes of data) to handle (handle must be block or line buffered).
---
--- Implementation:
---
--- for block/line buffering,
--- 1. If there isn't room in the handle buffer, flush the handle
--- buffer.
---
--- 2. If the handle buffer is empty,
--- if flush,
--- then write buf directly to the device.
--- else swap the handle buffer with buf.
---
--- 3. If the handle buffer is non-empty, copy buf into the
--- handle buffer. Then, if flush != 0, flush
--- the buffer.
-
-commitBuffer
- :: Handle -- handle to commit to
- -> RawBuffer -> Int -- address and size (in bytes) of buffer
- -> Int -- number of bytes of data in buffer
- -> Bool -- True <=> flush the handle afterward
- -> Bool -- release the buffer?
- -> IO Buffer
-
-commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
- wantWritableHandle "commitAndReleaseBuffer" hdl $
- commitBuffer' hdl raw sz count flush release
-
--- Explicitly lambda-lift this function to subvert GHC's full laziness
--- optimisations, which otherwise tends to float out subexpressions
--- past the \handle, which is really a pessimisation in this case because
--- that lambda is a one-shot lambda.
---
--- Don't forget to export the function, to stop it being inlined too
--- (this appears to be better than NOINLINE, because the strictness
--- analyser still gets to worker-wrapper it).
---
--- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
---
-commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
- handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
-
-#ifdef DEBUG_DUMP
- puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
- ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n")
-#endif
-
- old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size }
- <- readIORef ref
-
- buf_ret <-
- -- enough room in handle buffer?
- if (not flush && (size - w > count))
- -- The > is to be sure that we never exactly fill
- -- up the buffer, which would require a flush. So
- -- if copying the new data into the buffer would
- -- make the buffer full, we just flush the existing
- -- buffer and the new data immediately, rather than
- -- copying before flushing.
-
- -- not flushing, and there's enough room in the buffer:
- -- just copy the data in and update bufWPtr.
- then do memcpy_off old_raw w raw (fromIntegral count)
- writeIORef ref old_buf{ bufWPtr = w + count }
- return (newEmptyBuffer raw WriteBuffer sz)
-
- -- else, we have to flush
- else do flushed_buf <- flushWriteBuffer fd old_buf
-
- let this_buf =
- Buffer{ bufBuf=raw, bufState=WriteBuffer,
- bufRPtr=0, bufWPtr=count, bufSize=sz }
-
- -- if: (a) we don't have to flush, and
- -- (b) size(new buffer) == size(old buffer), and
- -- (c) new buffer is not full,
- -- we can just just swap them over...
- if (not flush && sz == size && count /= sz)
- then do
- writeIORef ref this_buf
- return flushed_buf
-
- -- otherwise, we have to flush the new data too,
- -- and start with a fresh buffer
- else do
- flushWriteBuffer fd this_buf
- writeIORef ref flushed_buf
- -- if the sizes were different, then allocate
- -- a new buffer of the correct size.
- if sz == size
- then return (newEmptyBuffer raw WriteBuffer sz)
- else allocateBuffer size WriteBuffer
-
- -- release the buffer if necessary
- case buf_ret of
- Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
- if release && buf_ret_sz == size
- then do
- spare_bufs <- readIORef spare_buf_ref
- writeIORef spare_buf_ref
- (BufferListCons buf_ret_raw spare_bufs)
- return buf_ret
- else
- return buf_ret
-
-
-foreign import "memcpy_PrelIO_wrap" unsafe
- memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
-#def inline \
-void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
-{ return memcpy(dst+dst_off, src, sz); }
-
--- ---------------------------------------------------------------------------
--- hPutStrLn
-
--- Derived action `hPutStrLn hdl str' writes the string `str' to
--- the handle `hdl', adding a newline at the end.
-
-hPutStrLn :: Handle -> String -> IO ()
-hPutStrLn hndl str = do
- hPutStr hndl str
- hPutChar hndl '\n'
-
--- ---------------------------------------------------------------------------
--- hPrint
-
--- Computation `hPrint hdl t' writes the string representation of `t'
--- given by the `shows' function to the file or channel managed by `hdl'.
-
-hPrint :: Show a => Handle -> a -> IO ()
-hPrint hdl = hPutStrLn hdl . show
projects / ghc-hetmet.git / commitdiff