X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=eae9a3affdadfd33d68333fc831052f4c0aa2801;hb=75ea0fa2485c169f0546d5d40477d2f6747efe29;hp=db9e886469967efa37fd13ed178b2b66d2e24cba;hpb=7de50399a42ee49b0473b7b6eea2b44a2f941a12;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index db9e886..eae9a3a 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,14 +1,21 @@ -{-# 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_, @@ -16,20 +23,25 @@ module GHC.Handle ( 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, HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, + SeekMode(..), hSeek, hTell, hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, hSetEcho, hGetEcho, hIsTerminalDevice, @@ -40,14 +52,16 @@ module GHC.Handle ( ) 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 @@ -118,12 +132,17 @@ withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a withHandle fun h@(FileHandle m) act = withHandle' fun h m act withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act +withHandle' :: String -> Handle -> MVar Handle__ + -> (Handle__ -> IO (Handle__,a)) -> IO a withHandle' fun h m act = block $ do h_ <- takeMVar m checkBufferInvariants h_ (h',v) <- catchException (act h_) - (\ 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 @@ -138,7 +157,10 @@ withHandle_' fun h m act = 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 @@ -154,17 +176,18 @@ withHandle__' fun h m 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 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. @@ -296,17 +319,14 @@ stdHandleFinalizer m = do 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 @@ -335,7 +355,15 @@ newEmptyBuffer b state size 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 @@ -416,21 +444,13 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do 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 } = @@ -452,9 +472,8 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do #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") @@ -467,12 +486,93 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do 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 @@ -539,18 +639,13 @@ 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 +addFilePathToIOError fun fp (IOError h iot _ str _) + = IOError h iot fun str (Just fp) openFile :: FilePath -> IOMode -> IO Handle openFile fp im = @@ -558,13 +653,13 @@ 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 = @@ -658,6 +753,12 @@ openFd fd mb_fd_type filepath mode binary truncate = do mkFileHandle fd is_stream filepath ha_type binary +fdToHandle :: FD -> IO Handle +fdToHandle fd = do + mode <- fdGetMode fd + let fd_str = "" + openFd fd Nothing fd_str mode True{-bin mode-} False{-no truncate-} + foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt @@ -728,7 +829,7 @@ mkDuplexHandle fd is_stream filepath binary = do } read_side <- newMVar r_handle_ - addMVarFinalizer read_side (handleFinalizer read_side) + addMVarFinalizer write_side (handleFinalizer write_side) return (DuplexHandle read_side write_side) @@ -756,40 +857,42 @@ 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 @@ -823,7 +926,7 @@ hIsEOF :: Handle -> IO Bool 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 @@ -914,7 +1017,11 @@ hSetBuffering handle mode = 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 @@ -938,7 +1045,7 @@ hFlush handle = writeIORef (haBuffer handle_) flushed_buf else return () - + -- ----------------------------------------------------------------------------- -- Repositioning Handles @@ -962,32 +1069,9 @@ type HandlePosition = Integer -- 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 @@ -1061,6 +1145,34 @@ hSeek handle mode offset = 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 @@ -1136,10 +1248,9 @@ hIsSeekable handle = || 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 @@ -1152,6 +1263,8 @@ 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 @@ -1163,6 +1276,8 @@ hGetEcho handle = do 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 @@ -1173,6 +1288,15 @@ hIsTerminalDevice 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" @@ -1182,12 +1306,74 @@ hSetBinaryMode handle bin = foreign import ccall unsafe "__hscore_setmode" setmode :: CInt -> Bool -> IO CInt +-- ----------------------------------------------------------------------------- +-- Duplicating a Handle + +-- |Returns a duplicate of the original handle, with its own buffer +-- 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