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(..), IOModeEx(..), openFile, openFileEx, openFd, fdToHandle,
hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
- hFlush,
+ hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
) 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
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 h_)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return v
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 h_)
+ _ -> throw err)
checkBufferInvariants h_
putMVar m h_
return v
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 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)
+augmentIOError (IOError _ iot _ str fp) fun h h_
+ = 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.
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
+ hClose_help h_
return ()
-- ---------------------------------------------------------------------------
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_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_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
+
+#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 =
(openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE
then BinaryMode im
else TextMode im))
- (\e -> throw (addFilePathToIOError "openFile" fp e))
+ (\e -> ioError (addFilePathToIOError "openFile" fp e))
openFileEx :: FilePath -> IOModeEx -> IO Handle
openFileEx fp m =
catch
(openFile' fp m)
- (\e -> throw (addFilePathToIOError "openFileEx" fp e))
+ (\e -> ioError (addFilePathToIOError "openFileEx" fp e))
openFile' filepath ex_mode =
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
}
read_side <- newMVar r_handle_
- addMVarFinalizer read_side (handleFinalizer read_side)
+ addMVarFinalizer write_side (handleFinalizer write_side)
return (DuplexHandle read_side write_side)
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
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 m) = do
+ new_h_ <- withHandle' "hDuplicate" h m (dupHandle_ Nothing)
+ new_m <- newMVar new_h_
+ return (FileHandle new_m)
+hDuplicate h@(DuplexHandle 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 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)
+
-- ---------------------------------------------------------------------------
-- 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