-{-# OPTIONS -fno-implicit-prelude -#include "HsCore.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
#undef DEBUG_DUMP
#undef DEBUG
--- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.2 2002/01/02 14:40:10 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,
+ 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,
HandlePosn(..), hGetPosn, hSetPosn,
- SeekMode(..), hSeek,
+ SeekMode(..), hSeek, hTell,
hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
hSetEcho, hGetEcho, hIsTerminalDevice,
- ioeGetFileName, ioeGetErrorString, ioeGetHandle,
#ifdef DEBUG_DUMP
puts,
) 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
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 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
- 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 (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 "__hscore_PrelHandle_write" unsafe
- write_off :: CInt -> Bool -> RawBuffer -> 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 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' }
-foreign import "__hscore_PrelHandle_read" unsafe
- read_off :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+-- 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_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 =
| otherwise = False
binary_flags
- | binary = GHC.Handle.o_BINARY
+ | binary = o_BINARY
| otherwise = 0
oflags = oflags1 .|. binary_flags
mkFileHandle fd is_stream filepath ha_type binary
-foreign import "lockFile" unsafe
+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
-foreign import "unlockFile" unsafe
+foreign import ccall unsafe "unlockFile"
unlockFile :: CInt -> IO CInt
mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode
}
read_side <- newMVar r_handle_
- addMVarFinalizer read_side (handleFinalizer read_side)
+ addMVarFinalizer write_side (handleFinalizer write_side)
return (DuplexHandle read_side write_side)
-- 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 = fromIntegral (haFD handle_)
- flushWriteBufferOnly handle_
-
- -- close the file descriptor, but not when this is the read side
- -- of a duplex handle.
- case haOtherSide handle_ of
- Nothing -> 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_) fd)
+ (closeFd (haIsStream handle_) c_fd)
#else
- (c_close fd)
+ (c_close c_fd)
#endif
- Just _ -> return ()
+ Just _ -> return ()
- -- 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
- })
+ -- 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
|| 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"
(setmode (fromIntegral (haFD handle_)) bin)
return handle_{haIsBin=bin}
-foreign import "__hscore_setmode" unsafe
+foreign import ccall unsafe "__hscore_setmode"
setmode :: CInt -> Bool -> IO CInt
-- -----------------------------------------------------------------------------
--- Miscellaneous
+-- 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_)
--- These three functions are meant to get things out of an IOError.
+-- -----------------------------------------------------------------------------
+-- Replacing a Handle
-ioeGetFileName :: IOError -> Maybe FilePath
-ioeGetErrorString :: IOError -> String
-ioeGetHandle :: IOError -> Maybe Handle
+{- |
+Makes the second handle a duplicate of the first handle. The second
+handle will be closed first, if it is not already.
-ioeGetHandle (IOException (IOError h _ _ _ _)) = h
-ioeGetHandle (UserError _) = Nothing
-ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+This can be used to retarget the standard Handles, for example:
-ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot
-ioeGetErrorString (UserError str) = str
-ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
+> do h <- openFile "mystdout" WriteMode
+> hDuplicateTo h stdout
+-}
-ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn
-ioeGetFileName (UserError _) = Nothing
-ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
+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 c_write 1 cstr (fromIntegral (length s))
+puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
return ()
#endif
-- -----------------------------------------------------------------------------
-- wrappers to platform-specific constants:
-foreign import ccall "__hscore_supportsTextMode" unsafe
+foreign import ccall unsafe "__hscore_supportsTextMode"
tEXT_MODE_SEEK_ALLOWED :: Bool
-foreign import ccall "__hscore_bufsiz" unsafe dEFAULT_BUFFER_SIZE :: Int
-foreign import ccall "__hscore_seek_cur" unsafe sEEK_CUR :: CInt
-foreign import ccall "__hscore_seek_set" unsafe sEEK_SET :: CInt
-foreign import ccall "__hscore_seek_end" unsafe sEEK_END :: CInt
-foreign import ccall "__hscore_o_binary" unsafe o_BINARY :: CInt
-
-
+foreign import ccall unsafe "__hscore_bufsiz" dEFAULT_BUFFER_SIZE :: Int
+foreign import ccall unsafe "__hscore_seek_cur" sEEK_CUR :: CInt
+foreign import ccall unsafe "__hscore_seek_set" sEEK_SET :: CInt
+foreign import ccall unsafe "__hscore_seek_end" sEEK_END :: CInt
projects / ghc-base.git / blobdiff