X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=49ab6dc020f5ed1e6cc428666237bd85252c5d36;hb=refs%2Ftags%2Farity-anal-branch-point;hp=d51e138d6bb7618fef6ff3dfa7b00644f24d69d5;hpb=b72dda8318394f238214364dc01b8963599f8cd6;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index d51e138..49ab6dc 100644 --- a/GHC/Handle.hs +++ b/GHC/Handle.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-} #undef DEBUG_DUMP #undef DEBUG @@ -17,30 +17,31 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.Handle ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer, + flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, + fillReadBuffer, fillReadBufferWithoutBlocking, readRawBuffer, readRawBufferPtr, writeRawBuffer, writeRawBufferPtr, + +#ifndef mingw32_HOST_OS unlockFile, - - {- ought to be unnecessary, but just in case.. -} - write_off, write_rawBuffer, - read_off, read_rawBuffer, +#endif ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, stdin, stdout, stderr, - IOMode(..), openFile, openBinaryFile, openFd, fdToHandle, - hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, + 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, @@ -54,8 +55,7 @@ module GHC.Handle ( ) where -#include "config.h" - +import System.Directory.Internals import Control.Monad import Data.Bits import Data.Maybe @@ -76,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 @@ -302,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" @@ -317,13 +324,21 @@ 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 +-- 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. + +stdHandleFinalizer :: FilePath -> MVar Handle__ -> IO () +stdHandleFinalizer fp m = do h_ <- takeMVar m flushWriteBufferOnly h_ + putMVar m (ioe_finalizedHandle fp) -handleFinalizer :: MVar Handle__ -> IO () -handleFinalizer m = do +handleFinalizer :: FilePath -> MVar Handle__ -> IO () +handleFinalizer fp m = do handle_ <- takeMVar m case haType handle_ of ClosedHandle -> return () @@ -332,6 +347,7 @@ handleFinalizer m = do -- descriptor anyway... hClose_handle_ handle_ return () + putMVar m (ioe_finalizedHandle fp) -- --------------------------------------------------------------------------- -- Grimy buffer operations @@ -360,7 +376,7 @@ newEmptyBuffer b state size allocateBuffer :: Int -> BufferState -> IO Buffer allocateBuffer sz@(I# size) state = IO $ \s -> -#ifdef mingw32_TARGET_OS +#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 @@ -441,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") @@ -492,90 +509,185 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do 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_TARGET_OS +#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 is_stream buf off len) - (threadWaitRead fd) + (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 is_stream buf off len) - (threadWaitRead fd) + (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) is_stream buf off len) - (threadWaitWrite fd) + (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) is_stream buf off len) - (threadWaitWrite fd) + (write_off (fromIntegral fd) buf off len) + (threadWaitWrite (fromIntegral fd)) foreign import ccall unsafe "__hscore_PrelHandle_read" - read_rawBuffer :: 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 -> Bool -> RawBuffer -> Int -> CInt -> IO CInt + write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt foreign import ccall unsafe "__hscore_PrelHandle_write" - write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt + write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt + +#else /* mingw32_HOST_OS.... */ -#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) +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 = 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) +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 = 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) +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 = 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 - +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 -- --------------------------------------------------------------------------- @@ -635,8 +747,8 @@ addFilePathToIOError fun fp (IOError h iot _ str _) -- 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 +-- 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. -- @@ -647,7 +759,9 @@ addFilePathToIOError fun fp (IOError h iot _ str _) -- * '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 @@ -674,14 +788,15 @@ openFile' filepath mode binary = let 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 @@ -698,11 +813,73 @@ openFile' filepath mode binary = 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 @@ -714,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 @@ -732,46 +909,47 @@ 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) - - -- truncate the file if necessary - when truncate (fileTruncate filepath) - - mkFileHandle fd is_stream filepath ha_type binary +#endif + mkFileHandle fd is_socket 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-} + 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 filepath stdHandleFinalizer + newFileHandle filepath (stdHandleFinalizer filepath) (Handle__ { haFD = fd, haType = ha_type, haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, @@ -786,7 +964,7 @@ 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 filepath handleFinalizer + newFileHandle filepath (handleFinalizer filepath) (Handle__ { haFD = fd, haType = ha_type, haIsBin = binary, @@ -827,7 +1005,7 @@ mkDuplexHandle fd is_stream filepath binary = do } read_side <- newMVar r_handle_ - addMVarFinalizer write_side (handleFinalizer write_side) + addMVarFinalizer write_side (handleFinalizer filepath write_side) return (DuplexHandle filepath read_side write_side) @@ -869,13 +1047,11 @@ hClose_handle_ handle_ = do 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. + -- side of a duplex handle. case haOtherSide handle_ of Nothing -> - when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $ throwErrnoIfMinus1Retry_ "hClose" -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS (closeFd (haIsStream handle_) c_fd) #else (c_close c_fd) @@ -885,9 +1061,11 @@ hClose_handle_ handle_ = do -- 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, @@ -895,7 +1073,7 @@ hClose_handle_ handle_ = do }) ----------------------------------------------------------------------------- --- 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 that file in 8-bit bytes. @@ -913,6 +1091,20 @@ 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 @@ -936,7 +1128,7 @@ isEOF = hIsEOF stdin -- --------------------------------------------------------------------------- -- Looking ahead --- | Computation 'hLookahead' returns the next character from the handle +-- | Computation 'hLookAhead' returns the next character from the handle -- without removing it from the input buffer, blocking until a character -- is available. -- @@ -970,7 +1162,7 @@ hLookAhead handle = do -- further explanation of what the type represent. -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for --- handle hdl on subsequent reads and writes. +-- handle @hdl@ on subsequent reads and writes. -- -- If the buffer mode is changed from 'BlockBuffering' or -- 'LineBuffering' to 'NoBuffering', then @@ -1021,10 +1213,12 @@ hSetBuffering handle mode = is_tty <- fdIsTTY (haFD handle_) when (is_tty && isReadableHandleType (haType handle_)) $ case mode of -#ifndef mingw32_TARGET_OS +#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 @@ -1037,7 +1231,7 @@ 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. +-- in handle @hdl@ to be sent immediately to the operating system. -- -- This operation may fail with: -- @@ -1174,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. @@ -1275,7 +1469,7 @@ hIsSeekable handle = -- ----------------------------------------------------------------------------- -- Changing echo status (Non-standard GHC extensions) --- | Set the echoing status of a handle connected to a terminal (GHC only). +-- | Set the echoing status of a handle connected to a terminal. hSetEcho :: Handle -> Bool -> IO () hSetEcho handle on = do @@ -1288,7 +1482,7 @@ hSetEcho handle on = do ClosedHandle -> ioe_closedHandle _ -> setEcho (haFD handle_) on --- | Get the echoing status of a handle connected to a terminal (GHC only). +-- | Get the echoing status of a handle connected to a terminal. hGetEcho :: Handle -> IO Bool hGetEcho handle = do @@ -1301,7 +1495,7 @@ hGetEcho handle = do ClosedHandle -> ioe_closedHandle _ -> getEcho (haFD handle_) --- | Is the handle connected to a terminal? (GHC only) +-- | Is the handle connected to a terminal? hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do @@ -1314,7 +1508,7 @@ hIsTerminalDevice handle = do -- hSetBinaryMode -- | Select binary mode ('True') or text mode ('False') on a open handle. --- (GHC only; see also 'openBinaryFile'.) +-- (See also 'openBinaryFile'.) hSetBinaryMode :: Handle -> Bool -> IO () hSetBinaryMode handle bin = @@ -1329,26 +1523,37 @@ foreign import ccall unsafe "__hscore_setmode" -- ----------------------------------------------------------------------------- -- 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. +-- | 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) - new_m <- newMVar new_h_ - return (FileHandle path new_m) + 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_ <- withHandle' "hDuplicate" h w (dupHandle Nothing) new_w <- newMVar new_w_ - new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just 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 +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_)) + 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 @@ -1376,14 +1581,14 @@ 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) + 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 (dupHandle_ Nothing) + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo Nothing w2_) withHandle__' "hDuplicateTo" h2 r2 $ \r2_ -> do _ <- hClose_help r2_ - withHandle' "hDuplicateTo" h1 r1 (dupHandle_ (Just w1)) + withHandle' "hDuplicateTo" h1 r1 (dupHandleTo (Just w1) r2_) hDuplicateTo h1 _ = ioException (IOError (Just h1) IllegalOperation "hDuplicateTo" "handles are incompatible" Nothing) @@ -1434,13 +1639,30 @@ showHandle' filepath is_duplex h = -- --------------------------------------------------------------------------- -- debugging -#ifdef DEBUG_DUMP +#if defined(DEBUG_DUMP) puts :: String -> IO () -puts s = withCString s $ \cstr -> do write_rawBuffer 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"