X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=49ab6dc020f5ed1e6cc428666237bd85252c5d36;hb=e47bbdf549338d7b6bdbb8c17ac11bbe73ebd6ac;hp=c29c6c9b41b3ad68f698f0c3239c86d8dc273dc4;hpb=7ff72f2628d225b08f7efdd21cb43514181b9bb7;p=haskell-directory.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index c29c6c9..49ab6dc 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,53 +1,69 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} #undef DEBUG_DUMP #undef DEBUG --- ----------------------------------------------------------------------------- --- $Id: Handle.hs,v 1.6 2002/03/26 17:06:32 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". +----------------------------------------------------------------------------- +-- #hide module GHC.Handle ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer, - read_off, read_off_ba, - write_off, write_off_ba, + flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, + fillReadBuffer, fillReadBufferWithoutBlocking, + readRawBuffer, readRawBufferPtr, + writeRawBuffer, writeRawBufferPtr, + +#ifndef mingw32_HOST_OS + unlockFile, +#endif ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, - hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, - hFlush, + IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle, + hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, + hFlush, hDuplicate, hDuplicateTo, hClose, hClose_help, - HandlePosn(..), hGetPosn, hSetPosn, + HandlePosition, HandlePosn(..), hGetPosn, hSetPosn, SeekMode(..), hSeek, hTell, hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, hSetEcho, hGetEcho, hIsTerminalDevice, + hShow, + #ifdef DEBUG_DUMP puts, #endif ) where +import System.Directory.Internals 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 @@ -60,6 +76,9 @@ import GHC.Enum import GHC.Num ( Integer(..), Num(..) ) import GHC.Show import GHC.Real ( toInteger ) +#if defined(DEBUG_DUMP) +import GHC.Pack +#endif import GHC.Conc @@ -82,11 +101,11 @@ dEFAULT_OPEN_IN_BINARY_MODE = False :: Bool -- --------------------------------------------------------------------------- -- 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 @@ -115,8 +134,8 @@ but we might want to revisit this in the future --SDM ]. {-# 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 @@ -125,29 +144,35 @@ withHandle' fun h m act = 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 @@ -156,25 +181,29 @@ 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) + _ -> 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 @@ -205,9 +234,9 @@ checkWritableHandle act handle_ -- 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 @@ -236,10 +265,10 @@ checkReadableHandle act handle_ = -- 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_ = @@ -276,6 +305,10 @@ ioe_notSeekable_notBin = ioException "seek operations on text-mode handles are not allowed on this platform" Nothing) +ioe_finalizedHandle fp = throw (IOException + (IOError Nothing IllegalOperation "" + "handle is finalized" (Just fp))) + ioe_bufsiz :: Int -> IO a ioe_bufsiz n = ioException (IOError Nothing InvalidArgument "hSetBuffering" @@ -291,24 +324,30 @@ ioe_bufsiz n = ioException -- The finalizer is then placed on the write side, and the handle only gets -- finalized once, when both sides are no longer required. -stdHandleFinalizer :: MVar Handle__ -> IO () -stdHandleFinalizer m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ +-- NOTE about finalized handles: It's possible that a handle can be +-- finalized and then we try to use it later, for example if the +-- handle is referenced from another finalizer, or from a thread that +-- has become unreferenced and then resurrected (arguably in the +-- latter case we shouldn't finalize the Handle...). Anyway, +-- we try to emit a helpful message which is better than nothing. -handleFinalizer :: MVar Handle__ -> IO () -handleFinalizer m = do +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp 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 () + putMVar m (ioe_finalizedHandle fp) + +handleFinalizer :: FilePath -> MVar Handle__ -> IO () +handleFinalizer fp m = do + 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 () + putMVar m (ioe_finalizedHandle fp) -- --------------------------------------------------------------------------- -- Grimy buffer operations @@ -337,7 +376,15 @@ newEmptyBuffer b state size allocateBuffer :: Int -> BufferState -> IO Buffer allocateBuffer sz@(I# size) state = IO $ \s -> +#ifdef mingw32_HOST_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 @@ -410,7 +457,8 @@ flushReadBuffer fd buf return buf{ bufWPtr=0, bufRPtr=0 } flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer -flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do +flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = + seq fd $ do -- strictness hack let bytes = w - r #ifdef DEBUG_DUMP puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") @@ -418,21 +466,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 } = @@ -454,9 +494,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") @@ -469,11 +508,187 @@ 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' } + +fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer +fillReadBufferWithoutBlocking fd is_stream + buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = + -- buffer better be empty: + assert (r == 0 && w == 0) $ do +#ifdef DEBUG_DUMP + puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n") +#endif + res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b + 0 (fromIntegral size) + let res' = fromIntegral res +#ifdef DEBUG_DUMP + puts ("fillReadBufferLoopNoBlock: res' = " ++ show res' ++ "\n") +#endif + return buf{ bufRPtr=0, bufWPtr=res' } + +-- Low level routines for reading/writing to (raw)buffers: + +#ifndef mingw32_HOST_OS +readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBuffer loc fd is_stream buf off len = + throwErrnoIfMinus1RetryMayBlock loc + (read_rawBuffer fd buf off len) + (threadWaitRead (fromIntegral fd)) + +readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBufferNoBlock loc fd is_stream buf off len = + throwErrnoIfMinus1RetryOnBlock loc + (read_rawBuffer fd buf off len) + (return 0) + +readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt +readRawBufferPtr loc fd is_stream buf off len = + throwErrnoIfMinus1RetryMayBlock loc + (read_off fd buf off len) + (threadWaitRead (fromIntegral fd)) + +writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +writeRawBuffer loc fd is_stream buf off len = + throwErrnoIfMinus1RetryMayBlock loc + (write_rawBuffer (fromIntegral fd) buf off len) + (threadWaitWrite (fromIntegral 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) buf off len) + (threadWaitWrite (fromIntegral fd)) + foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt + read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_read" - read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt + read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_PrelHandle_write" + write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_PrelHandle_write" + write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +#else /* mingw32_HOST_OS.... */ + +readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBuffer loc fd is_stream buf off len + | threaded = blockingReadRawBuffer loc fd is_stream buf off len + | otherwise = asyncReadRawBuffer loc fd is_stream buf off len + +readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt +readRawBufferPtr loc fd is_stream buf off len + | threaded = blockingReadRawBufferPtr loc fd is_stream buf off len + | otherwise = asyncReadRawBufferPtr loc fd is_stream buf off len + +writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +writeRawBuffer loc fd is_stream buf off len + | threaded = blockingWriteRawBuffer loc fd is_stream buf off len + | otherwise = asyncWriteRawBuffer loc fd is_stream buf off len + +writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt +writeRawBufferPtr loc fd is_stream buf off len + | threaded = blockingWriteRawBufferPtr loc fd is_stream buf off len + | otherwise = asyncWriteRawBufferPtr loc fd is_stream buf off len + +-- ToDo: we don't have a non-blocking primitve read on Win32 +readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt +readRawBufferNoBlock = readRawBufferNoBlock + +-- Async versions of the read/write primitives, for the non-threaded RTS + +asyncReadRawBuffer 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) + +asyncReadRawBufferPtr 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) + +asyncWriteRawBuffer 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) + +asyncWriteRawBufferPtr 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) + +-- Blocking versions of the read/write primitives, for the threaded RTS + +blockingReadRawBuffer loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + recv_rawBuffer fd buf off len +blockingReadRawBuffer loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + read_rawBuffer fd buf off len + +blockingReadRawBufferPtr loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + recv_off fd buf off len +blockingReadRawBufferPtr loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + read_off fd buf off len + +blockingWriteRawBuffer loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + send_rawBuffer (fromIntegral fd) buf off len +blockingWriteRawBuffer loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + write_rawBuffer (fromIntegral fd) buf off len + +blockingWriteRawBufferPtr loc fd True buf off len = + throwErrnoIfMinus1Retry loc $ + send_off (fromIntegral fd) buf off len +blockingWriteRawBufferPtr loc fd False buf off len = + throwErrnoIfMinus1Retry loc $ + write_off (fromIntegral fd) buf off len + +-- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. +-- These calls may block, but that's ok. + +foreign import ccall safe "__hscore_PrelHandle_read" + read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_read" + read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_write" + write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_recv" + recv_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_recv" + recv_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_send" + send_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt + +foreign import ccall safe "__hscore_PrelHandle_send" + send_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +foreign import ccall "rtsSupportsBoundThreads" threaded :: Bool +#endif -- --------------------------------------------------------------------------- -- Standard Handles @@ -487,6 +702,7 @@ fd_stdin = 0 :: FD fd_stdout = 1 :: FD fd_stderr = 2 :: FD +-- | A handle managing input from the Haskell program's standard input channel. stdin :: Handle stdin = unsafePerformIO $ do -- ToDo: acquire lock @@ -494,6 +710,7 @@ stdin = unsafePerformIO $ do (buf, bmode) <- getBuffer fd_stdin ReadBuffer mkStdHandle fd_stdin "" ReadHandle buf bmode +-- | A handle managing output to the Haskell program's standard output channel. stdout :: Handle stdout = unsafePerformIO $ do -- ToDo: acquire lock @@ -503,6 +720,7 @@ stdout = unsafePerformIO $ do (buf, bmode) <- getBuffer fd_stdout WriteBuffer mkStdHandle fd_stdout "" WriteHandle buf bmode +-- | A handle managing output to the Haskell program's standard error channel. stderr :: Handle stderr = unsafePerformIO $ do -- ToDo: acquire lock @@ -515,78 +733,70 @@ stderr = unsafePerformIO $ do -- --------------------------------------------------------------------------- -- Opening and Closing Files -{- -Computation `openFile file mode' allocates and returns a new, open -handle to manage the file `file'. It manages input if `mode' -is `ReadMode', output if `mode' is `WriteMode' or `AppendMode', -and both input and output if mode is `ReadWriteMode'. - -If the file does not exist and it is opened for output, it should be -created as a new file. If `mode' is `WriteMode' and the file -already exists, then it should be truncated to zero length. The -handle is positioned at the end of the file if `mode' is -`AppendMode', and otherwise at the beginning (in which case its -internal position is 0). - -Implementations should enforce, locally to the Haskell process, -multiple-reader single-writer locking on files, which is to say that -there may either be many handles on the same file which manage input, -or just one handle on the file which manages output. If any open or -semi-closed handle is managing a file for output, no new handle can be -allocated for that file. If any open or semi-closed handle is -managing a file for input, new handles can only be allocated if they -do not manage output. - -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) +-- | Computation 'openFile' @file mode@ allocates and returns a new, open +-- handle to manage the file @file@. It manages input if @mode@ +-- is 'ReadMode', output if @mode@ is 'WriteMode' or 'AppendMode', +-- and both input and output if mode is 'ReadWriteMode'. +-- +-- If the file does not exist and it is opened for output, it should be +-- created as a new file. If @mode@ is 'WriteMode' and the file +-- already exists, then it should be truncated to zero length. +-- Some operating systems delete empty files, so there is no guarantee +-- that the file will exist following an 'openFile' with @mode@ +-- 'WriteMode' unless it is subsequently written to successfully. +-- The handle is positioned at the end of the file if @mode@ is +-- 'AppendMode', and otherwise at the beginning (in which case its +-- internal position is 0). +-- The initial buffer mode is implementation-dependent. +-- +-- This operation may fail with: +-- +-- * 'isAlreadyInUseError' if the file is already open and cannot be reopened; +-- +-- * 'isDoesNotExistError' if the file does not exist; or +-- +-- * 'isPermissionError' if the user does not have permission to open the file. +-- +-- Note: if you will be working with files containing binary data, you'll want to +-- be using 'openBinaryFile'. 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)) - -openFileEx :: FilePath -> IOModeEx -> IO Handle -openFileEx fp m = + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE) + (\e -> ioError (addFilePathToIOError "openFile" fp e)) + +-- | Like 'openFile', but open the file in binary mode. +-- 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. Binary mode turns off all special +-- treatment of end-of-line and end-of-file characters. +-- (See also 'hSetBinaryMode'.) + +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 - ReadWriteMode -> rw_flags + ReadMode -> read_flags +#ifdef mingw32_HOST_OS + WriteMode -> write_flags .|. o_TRUNC +#else + WriteMode -> write_flags +#endif + ReadWriteMode -> rw_flags AppendMode -> append_flags - truncate | WriteMode <- mode = True - | otherwise = False - binary_flags | binary = o_BINARY | otherwise = 0 @@ -603,11 +813,73 @@ openFile' filepath ex_mode = throwErrnoIfMinus1Retry "openFile" (c_open f (fromIntegral oflags) 0o666) - openFd fd Nothing filepath mode binary truncate + fd_type <- fdType fd + + h <- openFd fd (Just fd_type) False filepath mode binary + `catchException` \e -> do c_close (fromIntegral fd); throw e + -- NB. don't forget to close the FD if openFd fails, otherwise + -- this FD leaks. -- ASSERT: if we just created the file, then openFd won't fail -- (so we don't need to worry about removing the newly created file -- in the event of an error). +#ifndef mingw32_HOST_OS + -- we want to truncate() if this is an open in WriteMode, but only + -- if the target is a RegularFile. ftruncate() fails on special files + -- like /dev/null. + if mode == WriteMode && fd_type == RegularFile + then throwErrnoIf (/=0) "openFile" + (c_ftruncate (fromIntegral fd) 0) + else return 0 +#endif + return h + + +-- | The function creates a temporary file in ReadWrite mode. +-- The created file isn\'t deleted automatically, so you need to delete it manually. +openTempFile :: FilePath -- ^ Directory in which to create the file + -> String -- ^ File name template. If the template is \"foo.ext\" then + -- the create file will be \"fooXXX.ext\" where XXX is some + -- random number. + -> IO (FilePath, Handle) +openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE + +-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments. +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True + +openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle) +openTempFile' loc tmp_dir template binary = do + pid <- c_getpid + findTempName pid + where + (prefix,suffix) = break (=='.') template + + oflags1 = rw_flags .|. o_EXCL + + binary_flags + | binary = o_BINARY + | otherwise = 0 + + oflags = oflags1 .|. binary_flags + + findTempName x = do + fd <- withCString filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError loc errno Nothing (Just tmp_dir)) + else do + h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True + `catchException` \e -> do c_close (fromIntegral fd); throw e + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = tmp_dir `joinFileName` filename + std_flags = o_NONBLOCK .|. o_NOCTTY output_flags = std_flags .|. o_CREAT @@ -619,8 +891,8 @@ append_flags = write_flags .|. o_APPEND -- --------------------------------------------------------------------------- -- openFd -openFd :: FD -> Maybe FDType -> FilePath -> IOMode -> Bool -> Bool -> IO Handle -openFd fd mb_fd_type filepath mode binary truncate = do +openFd :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool -> IO Handle +openFd fd mb_fd_type is_socket filepath mode binary = do -- turn on non-blocking mode setNonBlockingFD fd @@ -637,46 +909,52 @@ openFd fd mb_fd_type filepath mode binary truncate = do case mb_fd_type of Just x -> return x Nothing -> fdType fd - let is_stream = fd_type == Stream + case fd_type of Directory -> ioException (IOError Nothing InappropriateType "openFile" "is a directory" Nothing) Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_stream filepath binary - | otherwise -> mkFileHandle fd is_stream filepath ha_type binary + | ReadWriteHandle <- ha_type -> mkDuplexHandle fd is_socket filepath binary + | otherwise -> mkFileHandle fd is_socket filepath ha_type binary -- regular files need to be locked RegularFile -> do +#ifndef mingw32_HOST_OS r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" "file is locked" Nothing) +#endif + mkFileHandle fd is_socket filepath ha_type binary - -- truncate the file if necessary - when truncate (fileTruncate filepath) - mkFileHandle fd is_stream filepath ha_type binary +fdToHandle :: FD -> IO Handle +fdToHandle fd = do + mode <- fdGetMode fd + let fd_str = "" + openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} +#ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt foreign import ccall unsafe "unlockFile" unlockFile :: CInt -> IO CInt +#endif mkStdHandle :: FD -> FilePath -> HandleType -> IORef Buffer -> BufferMode -> IO Handle mkStdHandle fd filepath ha_type buf bmode = do spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer + newFileHandle filepath (stdHandleFinalizer filepath) (Handle__ { haFD = fd, haType = ha_type, haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, haIsStream = False, haBufferMode = bmode, - haFilePath = filepath, haBuffer = buf, haBuffers = spares, haOtherSide = Nothing @@ -686,13 +964,12 @@ mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle mkFileHandle fd is_stream filepath ha_type binary = do (buf, bmode) <- getBuffer fd (initBufferState ha_type) spares <- newIORef BufferListNil - newFileHandle handleFinalizer + newFileHandle filepath (handleFinalizer filepath) (Handle__ { haFD = fd, haType = ha_type, haIsBin = binary, haIsStream = is_stream, haBufferMode = bmode, - haFilePath = filepath, haBuffer = buf, haBuffers = spares, haOtherSide = Nothing @@ -708,7 +985,6 @@ mkDuplexHandle fd is_stream filepath binary = do haIsBin = binary, haIsStream = is_stream, haBufferMode = w_bmode, - haFilePath = filepath, haBuffer = w_buf, haBuffers = w_spares, haOtherSide = Nothing @@ -723,15 +999,14 @@ mkDuplexHandle fd is_stream filepath binary = do 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 filepath write_side) + return (DuplexHandle filepath read_side write_side) initBufferState ReadHandle = ReadBuffer @@ -740,16 +1015,18 @@ initBufferState _ = WriteBuffer -- --------------------------------------------------------------------------- -- Closing a handle --- Computation `hClose hdl' makes handle `hdl' closed. Before the --- computation finishes, any items buffered for output and not already --- sent to the operating system are flushed as for `hFlush'. - --- For a duplex handle, we close&flush the write side, and just close --- the read side. +-- | Computation 'hClose' @hdl@ makes handle @hdl@ closed. Before the +-- computation finishes, if @hdl@ is writable its buffer is flushed as +-- for 'hFlush'. +-- Performing 'hClose' on a handle that has already been closed has no effect; +-- doing so not an error. All other operations on a closed handle will fail. +-- If 'hClose' fails for any reason, any further operations (apart from +-- 'hClose') on the handle will still fail as if @hdl@ had been successfully +-- closed. 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 @@ -762,44 +1039,44 @@ 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" -#ifdef mingw32_TARGET_OS + _ -> 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. + case haOtherSide handle_ of + Nothing -> + throwErrnoIfMinus1Retry_ "hClose" +#ifdef mingw32_HOST_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 + -- free the spare buffers + writeIORef (haBuffers handle_) BufferListNil + +#ifndef mingw32_HOST_OS + -- unlock it + unlockFile c_fd +#endif - -- 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 - }) + -- 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 +-- Detecting and changing the size of a file --- For a handle `hdl' which attached to a physical file, `hFileSize --- hdl' returns the size of `hdl' in terms of the number of items --- which can be read from `hdl'. +-- | For a handle @hdl@ which attached to a physical file, +-- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes. hFileSize :: Handle -> IO Integer hFileSize handle = @@ -814,19 +1091,36 @@ hFileSize handle = else ioException (IOError Nothing InappropriateType "hFileSize" "not a regular file" Nothing) + +-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes. + +hSetFileSize :: Handle -> Integer -> IO () +hSetFileSize handle size = + withHandle_ "hSetFileSize" handle $ \ handle_ -> do + case haType handle_ of + ClosedHandle -> ioe_closedHandle + SemiClosedHandle -> ioe_closedHandle + _ -> do flushWriteBufferOnly handle_ + throwErrnoIf (/=0) "hSetFileSize" + (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size)) + return () + -- --------------------------------------------------------------------------- -- Detecting the End of Input --- For a readable handle `hdl', `hIsEOF hdl' returns --- `True' if no further input can be taken from `hdl' or for a --- physical file, if the current I/O position is equal to the length of --- the file. Otherwise, it returns `False'. +-- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns +-- 'True' if no further input can be taken from @hdl@ or for a +-- physical file, if the current I\/O position is equal to the length of +-- the file. Otherwise, it returns 'False'. 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) + +-- | The computation 'isEOF' is identical to 'hIsEOF', +-- except that it works only on 'stdin'. isEOF :: IO Bool isEOF = hIsEOF stdin @@ -834,9 +1128,13 @@ isEOF = hIsEOF stdin -- --------------------------------------------------------------------------- -- Looking ahead --- hLookahead returns the next character from the handle without --- removing it from the input buffer, blocking until a character is --- available. +-- | Computation 'hLookAhead' returns the next character from the handle +-- without removing it from the input buffer, blocking until a character +-- is available. +-- +-- This operation may fail with: +-- +-- * 'isEOFError' if the end of file has been reached. hLookAhead :: Handle -> IO Char hLookAhead handle = do @@ -863,23 +1161,21 @@ hLookAhead handle = do -- block-buffering or no-buffering. See GHC.IOBase for definition and -- further explanation of what the type represent. --- Computation `hSetBuffering hdl mode' sets the mode of buffering for --- handle hdl on subsequent reads and writes. +-- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for +-- handle @hdl@ on subsequent reads and writes. -- --- * If mode is LineBuffering, line-buffering should be enabled if possible. +-- If the buffer mode is changed from 'BlockBuffering' or +-- 'LineBuffering' to 'NoBuffering', then -- --- * If mode is `BlockBuffering size', then block-buffering --- should be enabled if possible. The size of the buffer is n items --- if size is `Just n' and is otherwise implementation-dependent. +-- * if @hdl@ is writable, the buffer is flushed as for 'hFlush'; -- --- * If mode is NoBuffering, then buffering is disabled if possible. - --- If the buffer mode is changed from BlockBuffering or --- LineBuffering to NoBuffering, then any items in the output --- buffer are written to the device, and any items in the input buffer --- are discarded. The default buffering mode when a handle is opened --- is implementation-dependent and may depend on the object which is --- attached to that handle. +-- * if @hdl@ is not writable, the contents of the buffer is discarded. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if the handle has already been used for reading +-- or writing and the implementation does not allow the buffering mode +-- to be changed. hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = @@ -917,7 +1213,13 @@ hSetBuffering handle mode = is_tty <- fdIsTTY (haFD handle_) when (is_tty && isReadableHandleType (haType handle_)) $ case mode of +#ifndef mingw32_HOST_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 +#else + NoBuffering -> return () +#endif _ -> setCooked (haFD handle_) True -- throw away spare buffers, they might be the wrong size @@ -928,9 +1230,16 @@ hSetBuffering handle mode = -- ----------------------------------------------------------------------------- -- hFlush --- The action `hFlush hdl' causes any items buffered for output --- in handle `hdl' to be sent immediately to the operating --- system. +-- | The action 'hFlush' @hdl@ causes any items buffered for output +-- in handle @hdl@ to be sent immediately to the operating system. +-- +-- This operation may fail with: +-- +-- * 'isFullError' if the device is full; +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. +-- It is unspecified whether the characters in the buffer are discarded +-- or retained under these circumstances. hFlush :: Handle -> IO () hFlush handle = @@ -941,7 +1250,7 @@ hFlush handle = writeIORef (haBuffer handle_) flushed_buf else return () - + -- ----------------------------------------------------------------------------- -- Repositioning Handles @@ -960,40 +1269,38 @@ instance Show HandlePosn where -- that reports the position back via (merely) an Int. type HandlePosition = Integer --- Computation `hGetPosn hdl' returns the current I/O position of --- `hdl' as an abstract position. Computation `hSetPosn p' sets the --- position of `hdl' to a previously obtained position `p'. +-- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of +-- @hdl@ as a value of the abstract type 'HandlePosn'. hGetPosn :: Handle -> IO HandlePosn hGetPosn handle = do posn <- hTell handle return (HandlePosn handle posn) +-- | If a call to 'hGetPosn' @hdl@ returns a position @p@, +-- then computation 'hSetPosn' @p@ sets the position of @hdl@ +-- to the position it held at the time of the call to 'hGetPosn'. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. + hSetPosn :: HandlePosn -> IO () hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i -- --------------------------------------------------------------------------- -- hSeek -{- -The action `hSeek hdl mode i' sets the position of handle -`hdl' depending on `mode'. If `mode' is - - * AbsoluteSeek - The position of `hdl' is set to `i'. - * RelativeSeek - The position of `hdl' is set to offset `i' from - the current position. - * SeekFromEnd - The position of `hdl' is set to offset `i' from - the end of the file. - -Some handles may not be seekable (see `hIsSeekable'), or only -support a subset of the possible positioning operations (e.g. it may -only be possible to seek to the end of a tape, or to a positive -offset from the beginning or current position). - -It is not possible to set a negative I/O position, or for a physical -file, an I/O position beyond the current end-of-file. +-- | A mode that determines the effect of 'hSeek' @hdl mode i@, as follows: +data SeekMode + = AbsoluteSeek -- ^ the position of @hdl@ is set to @i@. + | RelativeSeek -- ^ the position of @hdl@ is set to offset @i@ + -- from the current position. + | SeekFromEnd -- ^ the position of @hdl@ is set to offset @i@ + -- from the end of the file. + deriving (Eq, Ord, Ix, Enum, Read, Show) -Note: +{- Note: - when seeking using `SeekFromEnd', positive offsets (>=0) means seeking at or past EOF. @@ -1002,8 +1309,23 @@ Note: clear here. -} -data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd - deriving (Eq, Ord, Ix, Enum, Read, Show) +-- | Computation 'hSeek' @hdl mode i@ sets the position of handle +-- @hdl@ depending on @mode@. +-- The offset @i@ is given in terms of 8-bit bytes. +-- +-- If @hdl@ is block- or line-buffered, then seeking to a position which is not +-- in the current buffer will first cause any items in the output buffer to be +-- written to the device, and then cause the input buffer to be discarded. +-- Some handles may not be seekable (see 'hIsSeekable'), or only support a +-- subset of the possible positioning operations (for instance, it may only +-- be possible to seek to the end of a tape, or to a positive offset from +-- the beginning or current position). +-- It is not possible to set a negative I\/O position, or for +-- a physical file, an I\/O position beyond the current end-of-file. +-- +-- This operation may fail with: +-- +-- * 'isPermissionError' if a system resource limit would be exceeded. hSeek :: Handle -> SeekMode -> Integer -> IO () hSeek handle mode offset = @@ -1046,7 +1368,7 @@ hTell :: Handle -> IO Integer hTell handle = wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do -#if defined(mingw32_TARGET_OS) +#if defined(mingw32_HOST_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. @@ -1102,7 +1424,7 @@ hIsClosed handle = -} hIsReadable :: Handle -> IO Bool -hIsReadable (DuplexHandle _ _) = return True +hIsReadable (DuplexHandle _ _ _) = return True hIsReadable handle = withHandle_ "hIsReadable" handle $ \ handle_ -> do case haType handle_ of @@ -1111,7 +1433,7 @@ hIsReadable handle = 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 @@ -1119,7 +1441,8 @@ hIsWritable handle = SemiClosedHandle -> ioe_closedHandle htype -> return (isWritableHandleType htype) --- Querying how a handle buffers its data: +-- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode +-- for @hdl@. hGetBuffering :: Handle -> IO BufferMode hGetBuffering handle = @@ -1144,10 +1467,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. hSetEcho :: Handle -> Bool -> IO () hSetEcho handle on = do @@ -1160,6 +1482,8 @@ hSetEcho handle on = do ClosedHandle -> ioe_closedHandle _ -> setEcho (haFD handle_) on +-- | Get the echoing status of a handle connected to a terminal. + hGetEcho :: Handle -> IO Bool hGetEcho handle = do isT <- hIsTerminalDevice handle @@ -1171,6 +1495,8 @@ hGetEcho handle = do ClosedHandle -> ioe_closedHandle _ -> getEcho (haFD handle_) +-- | Is the handle connected to a terminal? + hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do @@ -1181,6 +1507,9 @@ hIsTerminalDevice handle = do -- ----------------------------------------------------------------------------- -- hSetBinaryMode +-- | Select binary mode ('True') or text mode ('False') on a open handle. +-- (See also 'openBinaryFile'.) + hSetBinaryMode :: Handle -> Bool -> IO () hSetBinaryMode handle bin = withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> @@ -1191,16 +1520,149 @@ 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. +-- The two Handles will share a file pointer, however. 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) + newFileHandle path (handleFinalizer path) new_h_ +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_ + addMVarFinalizer new_w (handleFinalizer path new_w) + 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 <- throwErrnoIfMinus1 "dupHandle" $ + c_dup (fromIntegral (haFD h_)) + dupHandle_ other_side h_ new_fd + +dupHandleTo other_side hto_ h_ = do + flushBuffer h_ + new_fd <- throwErrnoIfMinus1 "dupHandleTo" $ + c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_)) + dupHandle_ other_side h_ new_fd + +dupHandle_ other_side h_ new_fd = do + 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 (dupHandleTo Nothing h2_) +hDuplicateTo h1@(DuplexHandle _ r1 w1) h2@(DuplexHandle _ r2 w2) = do + withHandle__' "hDuplicateTo" h2 w2 $ \w2_ -> do + _ <- hClose_help w2_ + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_) + withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do + _ <- hClose_help r2_ + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) +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 +#if defined(DEBUG_DUMP) puts :: String -> IO () -puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s)) - return () +puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s)) + return () #endif -- ----------------------------------------------------------------------------- +-- utils + +throwErrnoIfMinus1RetryOnBlock :: String -> IO CInt -> IO CInt -> IO CInt +throwErrnoIfMinus1RetryOnBlock loc f on_block = + do + res <- f + if (res :: CInt) == -1 + then do + err <- getErrno + if err == eINTR + then throwErrnoIfMinus1RetryOnBlock loc f on_block + else if err == eWOULDBLOCK || err == eAGAIN + then do on_block + else throwErrno loc + else return res + +-- ----------------------------------------------------------------------------- -- wrappers to platform-specific constants: foreign import ccall unsafe "__hscore_supportsTextMode"