-{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
#undef DEBUG_DUMP
#undef DEBUG
--- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.3 2002/02/05 17:32:26 simonmar Exp $
+-----------------------------------------------------------------------------
+-- |
+-- Module : GHC.Handle
+-- Copyright : (c) The University of Glasgow, 1994-2001
+-- License : see libraries/base/LICENSE
+--
+-- Maintainer : libraries@haskell.org
+-- Stability : internal
+-- Portability : non-portable
--
--- (c) The University of Glasgow, 1994-2001
+-- This module defines the basic operations on I\/O \"handles\".
--
--- This module defines the basic operations on I/O "handles".
+-----------------------------------------------------------------------------
module GHC.Handle (
withHandle, withHandle', withHandle_,
newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
- read_off, read_off_ba,
- write_off, write_off_ba,
+ readRawBuffer, readRawBufferPtr,
+ writeRawBuffer, writeRawBufferPtr,
+ unlockFile,
+
+ {- ought to be unnecessary, but just in case.. -}
+ write_off, write_rawBuffer,
+ read_off, read_rawBuffer,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
stdin, stdout, stderr,
- IOMode(..), IOModeEx(..), openFile, openFileEx, openFd,
+ IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
- hFlush,
+ hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
HandlePosn(..), hGetPosn, hSetPosn,
- SeekMode(..), hSeek,
+ SeekMode(..), hSeek, hTell,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
hSetEcho, hGetEcho, hIsTerminalDevice,
+ hShow,
+
#ifdef DEBUG_DUMP
puts,
#endif
) where
+#include "config.h"
+
import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import System.IO.Error
+import System.Posix.Internals
-import GHC.Posix
import GHC.Real
import GHC.Arr
-- ---------------------------------------------------------------------------
-- Creating a new handle
-newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
-newFileHandle finalizer hc = do
+newFileHandle :: FilePath -> (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle
+newFileHandle filepath finalizer hc = do
m <- newMVar hc
addMVarFinalizer m (finalizer m)
- return (FileHandle m)
+ return (FileHandle filepath m)
-- ---------------------------------------------------------------------------
-- Working with Handles
{-# INLINE withHandle #-}
withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle fun h@(FileHandle m) act = withHandle' fun h m act
-withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act
+withHandle fun h@(FileHandle _ m) act = withHandle' fun h m act
+withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
+withHandle' :: String -> Handle -> MVar Handle__
+ -> (Handle__ -> IO (Handle__,a)) -> IO a
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_))
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return v
{-# INLINE withHandle_ #-}
withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
-withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act
-withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act
+withHandle_ fun h@(FileHandle _ m) act = withHandle_' fun h m act
+withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
withHandle_' fun h m act =
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
v <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h_
putMVar m h_
return v
withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
-withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act
-withAllHandles__ fun h@(DuplexHandle r w) act = do
+withAllHandles__ fun h@(FileHandle _ m) act = withHandle__' fun h m act
+withAllHandles__ fun h@(DuplexHandle _ r w) act = do
withHandle__' fun h r act
withHandle__' fun h w act
h_ <- takeMVar m
checkBufferInvariants h_
h' <- catchException (act h_)
- (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_))
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return ()
-augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_
- = IOException (IOError (Just h) iot fun str filepath)
- where filepath | Just _ <- fp = fp
- | otherwise = Just (haFilePath h_)
-augmentIOError other_exception _ _ _
- = other_exception
+augmentIOError (IOError _ iot _ str fp) fun h
+ = IOError (Just h) iot fun str filepath
+ where filepath
+ | Just _ <- fp = fp
+ | otherwise = case h of
+ FileHandle fp _ -> Just fp
+ DuplexHandle fp _ _ -> Just fp
-- ---------------------------------------------------------------------------
-- Wrapper for write operations.
wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantWritableHandle fun h@(FileHandle m) act
+wantWritableHandle fun h@(FileHandle _ m) act
= wantWritableHandle' fun h m act
-wantWritableHandle fun h@(DuplexHandle _ m) act
+wantWritableHandle fun h@(DuplexHandle _ _ m) act
= wantWritableHandle' fun h m act
-- ToDo: in the Duplex case, we don't need to checkWritableHandle
-- Wrapper for read operations.
wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantReadableHandle fun h@(FileHandle m) act
+wantReadableHandle fun h@(FileHandle _ m) act
= wantReadableHandle' fun h m act
-wantReadableHandle fun h@(DuplexHandle m _) act
+wantReadableHandle fun h@(DuplexHandle _ m _) act
= wantReadableHandle' fun h m act
-- ToDo: in the Duplex case, we don't need to checkReadableHandle
-- Wrapper for seek operations.
wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
-wantSeekableHandle fun h@(DuplexHandle _ _) _act =
+wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
ioException (IOError (Just h) IllegalOperation fun
"handle is not seekable" Nothing)
-wantSeekableHandle fun h@(FileHandle m) act =
+wantSeekableHandle fun h@(FileHandle _ m) act =
withHandle_' fun h m (checkSeekableHandle act)
checkSeekableHandle act handle_ =
handleFinalizer :: MVar Handle__ -> IO ()
handleFinalizer m = do
- h_ <- takeMVar m
- flushWriteBufferOnly h_
- let fd = fromIntegral (haFD h_)
- unlockFile fd
- when (fd /= -1)
-#ifdef mingw32_TARGET_OS
- (closeFd (haIsStream h_) fd >> return ())
-#else
- (c_close fd >> return ())
-#endif
- return ()
+ 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 ()
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
allocateBuffer :: Int -> BufferState -> IO Buffer
allocateBuffer sz@(I# size) state = IO $ \s ->
+#ifdef mingw32_TARGET_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
if bytes == 0
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
- res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
- (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
- (fromIntegral bytes))
- (threadWaitWrite fd)
+ res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
+ (fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
else return buf{ bufRPtr=0, bufWPtr=0 }
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
- res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
- (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
- (threadWaitRead fd)
+ res <- readRawBuffer "fillReadBuffer" fd is_stream b
+ (fromIntegral w) (fromIntegral bytes)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+-- Low level routines for reading/writing to (raw)buffers:
+
+#ifndef mingw32_TARGET_OS
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (read_rawBuffer fd is_stream buf off len)
+ (threadWaitRead fd)
+
+readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtr loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (read_off fd is_stream buf off len)
+ (threadWaitRead fd)
+
+writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+writeRawBuffer loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (write_rawBuffer (fromIntegral fd) is_stream buf off len)
+ (threadWaitWrite fd)
+
+writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (write_off (fromIntegral fd) is_stream buf off len)
+ (threadWaitWrite fd)
+
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+ read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_read"
read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+
+#else
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+writeRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+
+#endif
+
-- ---------------------------------------------------------------------------
-- Standard Handles
implementation is free to impose stricter conditions.
-}
-data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode
- deriving (Eq, Ord, Ix, Enum, Read, Show)
-
-data IOModeEx
- = BinaryMode IOMode
- | TextMode IOMode
- deriving (Eq, Read, Show)
-
-addFilePathToIOError fun fp (IOException (IOError h iot _ str _))
- = IOException (IOError h iot fun str (Just fp))
-addFilePathToIOError _ _ other_exception
- = other_exception
+addFilePathToIOError fun fp (IOError h iot _ str _)
+ = IOError h iot fun str (Just fp)
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))
+ (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
+ (\e -> ioError (addFilePathToIOError "openFile" fp e))
-openFileEx :: FilePath -> IOModeEx -> IO Handle
-openFileEx fp m =
+openBinaryFile :: FilePath -> IOMode -> IO Handle
+openBinaryFile fp m =
catch
- (openFile' fp m)
- (\e -> throw (addFilePathToIOError "openFileEx" fp e))
-
+ (openFile' fp m True)
+ (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
-openFile' filepath ex_mode =
+openFile' filepath mode binary =
withCString filepath $ \ f ->
let
- (mode, binary) =
- case ex_mode of
- BinaryMode bmo -> (bmo, True)
- TextMode tmo -> (tmo, False)
-
oflags1 = case mode of
ReadMode -> read_flags
WriteMode -> write_flags
mkFileHandle fd is_stream filepath ha_type binary
+fdToHandle :: FD -> IO Handle
+fdToHandle fd = do
+ mode <- fdGetMode fd
+ let fd_str = "<file descriptor: " ++ show fd ++ ">"
+ openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-}
+
foreign import ccall unsafe "lockFile"
lockFile :: CInt -> CInt -> CInt -> IO CInt
-> IO Handle
mkStdHandle fd filepath ha_type buf bmode = do
spares <- newIORef BufferListNil
- newFileHandle stdHandleFinalizer
+ newFileHandle filepath stdHandleFinalizer
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = dEFAULT_OPEN_IN_BINARY_MODE,
haIsStream = False,
haBufferMode = bmode,
- haFilePath = filepath,
haBuffer = buf,
haBuffers = spares,
haOtherSide = Nothing
mkFileHandle fd is_stream filepath ha_type binary = do
(buf, bmode) <- getBuffer fd (initBufferState ha_type)
spares <- newIORef BufferListNil
- newFileHandle handleFinalizer
+ newFileHandle filepath handleFinalizer
(Handle__ { haFD = fd,
haType = ha_type,
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = bmode,
- haFilePath = filepath,
haBuffer = buf,
haBuffers = spares,
haOtherSide = Nothing
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = w_bmode,
- haFilePath = filepath,
haBuffer = w_buf,
haBuffers = w_spares,
haOtherSide = Nothing
haIsBin = binary,
haIsStream = is_stream,
haBufferMode = r_bmode,
- haFilePath = filepath,
haBuffer = r_buf,
haBuffers = r_spares,
haOtherSide = Just write_side
}
read_side <- newMVar r_handle_
- addMVarFinalizer read_side (handleFinalizer read_side)
- return (DuplexHandle read_side write_side)
+ addMVarFinalizer write_side (handleFinalizer write_side)
+ return (DuplexHandle filepath read_side write_side)
initBufferState ReadHandle = ReadBuffer
-- the read side.
hClose :: Handle -> IO ()
-hClose h@(FileHandle m) = hClose' h m
-hClose h@(DuplexHandle r w) = hClose' h w >> hClose' h r
+hClose h@(FileHandle _ m) = hClose' h m
+hClose h@(DuplexHandle _ r w) = hClose' h w >> hClose' h r
hClose' h m = withHandle__' "hClose" h m $ hClose_help
-- 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
- let fd = haFD handle_
- c_fd = fromIntegral fd
-
- flushWriteBufferOnly handle_
-
- -- close the file descriptor, but not when this is the read
- -- side of a duplex handle, and not when this is one of the
- -- std file handles.
- case haOtherSide handle_ of
- Nothing ->
- when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
- throwErrnoIfMinus1Retry_ "hClose"
+ _ -> do flushWriteBufferOnly handle_ -- interruptible
+ hClose_handle_ handle_
+
+hClose_handle_ handle_ = do
+ let fd = haFD handle_
+ c_fd = fromIntegral fd
+
+ -- close the file descriptor, but not when this is the read
+ -- side of a duplex handle, and not when this is one of the
+ -- std file handles.
+ case haOtherSide handle_ of
+ Nothing ->
+ when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+ throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_TARGET_OS
(closeFd (haIsStream handle_) c_fd)
#else
(c_close c_fd)
#endif
- Just _ -> return ()
+ Just _ -> return ()
- -- free the spare buffers
- writeIORef (haBuffers handle_) BufferListNil
-
- -- unlock it
- unlockFile c_fd
-
- -- 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
- })
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+ -- unlock it
+ unlockFile c_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
hIsEOF handle =
catch
(do hLookAhead handle; return False)
- (\e -> if isEOFError e then return True else throw e)
+ (\e -> if isEOFError e then return True else ioError e)
isEOF :: IO Bool
isEOF = hIsEOF stdin
is_tty <- fdIsTTY (haFD handle_)
when (is_tty && isReadableHandleType (haType handle_)) $
case mode of
+#ifndef mingw32_TARGET_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
+#endif
_ -> setCooked (haFD handle_) True
-- throw away spare buffers, they might be the wrong size
writeIORef (haBuffer handle_) flushed_buf
else return ()
-
+
-- -----------------------------------------------------------------------------
-- Repositioning Handles
-- position of `hdl' to a previously obtained position `p'.
hGetPosn :: Handle -> IO HandlePosn
-hGetPosn handle =
- wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
-
-#if defined(mingw32_TARGET_OS)
- -- urgh, on Windows we have to worry about \n -> \r\n translation,
- -- so we can't easily calculate the file position using the
- -- current buffer size. Just flush instead.
- flushBuffer handle_
-#endif
- let fd = fromIntegral (haFD handle_)
- 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 (HandlePosn handle real_posn)
-
+hGetPosn handle = do
+ posn <- hTell handle
+ return (HandlePosn handle posn)
hSetPosn :: HandlePosn -> IO ()
hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
writeIORef ref new_buf
do_seek
+
+hTell :: Handle -> IO Integer
+hTell handle =
+ wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do
+
+#if defined(mingw32_TARGET_OS)
+ -- urgh, on Windows we have to worry about \n -> \r\n translation,
+ -- so we can't easily calculate the file position using the
+ -- current buffer size. Just flush instead.
+ flushBuffer handle_
+#endif
+ let fd = fromIntegral (haFD handle_)
+ 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
-}
hIsReadable :: Handle -> IO Bool
-hIsReadable (DuplexHandle _ _) = return True
+hIsReadable (DuplexHandle _ _ _) = return True
hIsReadable handle =
withHandle_ "hIsReadable" handle $ \ handle_ -> do
case haType handle_ of
htype -> return (isReadableHandleType htype)
hIsWritable :: Handle -> IO Bool
-hIsWritable (DuplexHandle _ _) = return False
+hIsWritable (DuplexHandle _ _ _) = return True
hIsWritable handle =
withHandle_ "hIsWritable" handle $ \ handle_ -> do
case haType handle_ of
|| tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
--- Changing echo status
+-- Changing echo status (Non-standard GHC extensions)
--- Non-standard GHC extension is to allow the echoing status
--- of a handles connected to terminals to be reconfigured:
+-- | Set the echoing status of a handle connected to a terminal (GHC only).
hSetEcho :: Handle -> Bool -> IO ()
hSetEcho handle on = do
ClosedHandle -> ioe_closedHandle
_ -> setEcho (haFD handle_) on
+-- | Get the echoing status of a handle connected to a terminal (GHC only).
+
hGetEcho :: Handle -> IO Bool
hGetEcho handle = do
isT <- hIsTerminalDevice handle
ClosedHandle -> ioe_closedHandle
_ -> getEcho (haFD handle_)
+-- | Is the handle connected to a terminal? (GHC only)
+
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
-- -----------------------------------------------------------------------------
-- hSetBinaryMode
+-- | 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. Setting binary mode using
+-- 'hSetBinaryMode' turns off all special treatment of end-of-line and
+-- end-of-file characters.
+--
+hSetBinaryMode :: Handle -> Bool -> IO ()
hSetBinaryMode handle bin =
withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
do throwErrnoIfMinus1_ "hSetBinaryMode"
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
+-- and file pointer. The original handle's buffer is flushed, including
+-- discarding any input data, before the handle is duplicated.
+
+hDuplicate :: Handle -> IO Handle
+hDuplicate h@(FileHandle path m) = do
+ new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
+ new_m <- newMVar new_h_
+ return (FileHandle path new_m)
+hDuplicate h@(DuplexHandle path r w) = do
+ new_w_ <- withHandle' "hDuplicate" h w (dupHandle_ Nothing)
+ new_w <- newMVar new_w_
+ new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
+ new_r <- newMVar new_r_
+ return (DuplexHandle path new_r new_w)
+
+dupHandle_ other_side h_ = do
+ -- flush the buffer first, so we don't have to copy its contents
+ flushBuffer h_
+ new_fd <- c_dup (fromIntegral (haFD h_))
+ buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
+ ioref <- newIORef buffer
+ ioref_buffers <- newIORef BufferListNil
+
+ let new_handle_ = h_{ haFD = fromIntegral new_fd,
+ haBuffer = ioref,
+ haBuffers = ioref_buffers,
+ haOtherSide = other_side }
+ return (h_, new_handle_)
+
+-- -----------------------------------------------------------------------------
+-- Replacing a Handle
+
+{- |
+Makes the second handle a duplicate of the first handle. The second
+handle will be closed first, if it is not already.
+
+This can be used to retarget the standard Handles, for example:
+
+> do h <- openFile "mystdout" WriteMode
+> hDuplicateTo h stdout
+-}
+
+hDuplicateTo :: Handle -> Handle -> IO ()
+hDuplicateTo h1@(FileHandle _ m1) h2@(FileHandle _ m2) = do
+ withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
+ _ <- hClose_help h2_
+ withHandle' "hDuplicateTo" h1 m1 (dupHandle_ Nothing)
+hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do
+ withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do
+ _ <- hClose_help w2_
+ withHandle' "hDuplicateTo" h1 r1 (dupHandle_ Nothing)
+ withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do
+ _ <- hClose_help r2_
+ withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1))
+hDuplicateTo h1 _ =
+ ioException (IOError (Just h1) IllegalOperation "hDuplicateTo"
+ "handles are incompatible" Nothing)
+
+-- ---------------------------------------------------------------------------
+-- showing Handles.
+--
+-- hShow is in the IO monad, and gives more comprehensive output
+-- than the (pure) instance of Show for Handle.
+
+hShow :: Handle -> IO String
+hShow h@(FileHandle path _) = showHandle' path False h
+hShow h@(DuplexHandle path _ _) = showHandle' path True h
+
+showHandle' filepath is_duplex h =
+ withHandle_ "showHandle" h $ \hdl_ ->
+ let
+ showType | is_duplex = showString "duplex (read-write)"
+ | otherwise = shows (haType hdl_)
+ in
+ return
+ (( showChar '{' .
+ showHdl (haType hdl_)
+ (showString "loc=" . showString filepath . showChar ',' .
+ showString "type=" . showType . showChar ',' .
+ showString "binary=" . shows (haIsBin hdl_) . showChar ',' .
+ showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
+ ) "")
+ where
+
+ showHdl :: HandleType -> ShowS -> ShowS
+ showHdl ht cont =
+ case ht of
+ ClosedHandle -> shows ht . showString "}"
+ _ -> cont
+
+ showBufMode :: Buffer -> BufferMode -> ShowS
+ showBufMode buf bmo =
+ case bmo of
+ NoBuffering -> showString "none"
+ LineBuffering -> showString "line"
+ BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
+ BlockBuffering Nothing -> showString "block " . showParen True (shows def)
+ where
+ def :: Int
+ def = bufSize buf
+
-- ---------------------------------------------------------------------------
-- debugging
#ifdef DEBUG_DUMP
puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
+puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
return ()
#endif
projects / haskell-directory.git / blobdiff