#undef DEBUG_DUMP
#undef DEBUG
--- -----------------------------------------------------------------------------
--- $Id: Handle.hs,v 1.5 2002/02/27 14:32:23 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,
+ write_off, write_off_ba, unlockFile,
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
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)
+ let
+ -- hClose puts both the fd and the handle's type
+ -- into a closed state, so it's a bit excessive
+ -- to test for both here, but caution sometimes
+ -- pays off..
+ alreadyClosed =
+ case haType h_ of { ClosedHandle{} -> True; _ -> False }
+ fd = fromIntegral (haFD h_)
+
+ when (not alreadyClosed && fd /= -1) $ do
+ flushWriteBufferOnly h_
+ unlockFile fd
#ifdef mingw32_TARGET_OS
(closeFd (haIsStream h_) fd >> return ())
#else
(c_close fd >> return ())
#endif
- return ()
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
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
-- 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_
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
-- -----------------------------------------------------------------------------
-- 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 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
projects / ghc-base.git / blobdiff