X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=513a4a40f3c4d2f8f9f7f91115422b7a357f757f;hb=88b22778e7c06909683b493e037605a249ae37ad;hp=f79a2cbb9c8064585cb5bc99cd2353dc54928e65;hpb=a0072d5e485d323656906f6d8ac64606972bf2ee;p=ghc-base.git diff --git a/GHC/Handle.hs b/GHC/Handle.hs index f79a2cb..513a4a4 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,6 +17,7 @@ -- ----------------------------------------------------------------------------- +-- #hide module GHC.Handle ( withHandle, withHandle', withHandle_, wantWritableHandle, wantReadableHandle, wantSeekableHandle, @@ -27,7 +28,7 @@ module GHC.Handle ( readRawBuffer, readRawBufferPtr, writeRawBuffer, writeRawBufferPtr, -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS unlockFile, #endif @@ -54,8 +55,7 @@ module GHC.Handle ( ) where -#include "ghcconfig.h" - +import System.Directory.Internals import Control.Monad import Data.Bits import Data.Maybe @@ -63,7 +63,6 @@ import Foreign import Foreign.C import System.IO.Error import System.Posix.Internals -import System.FilePath import GHC.Real @@ -374,7 +373,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 @@ -525,7 +524,7 @@ fillReadBufferWithoutBlocking fd is_stream -- 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 @@ -568,7 +567,7 @@ foreign import ccall unsafe "__hscore_PrelHandle_write" foreign import ccall unsafe "__hscore_PrelHandle_write" write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt -#else /* mingw32_TARGET_OS.... */ +#else /* mingw32_HOST_OS.... */ readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt readRawBuffer loc fd is_stream buf off len @@ -787,7 +786,7 @@ openFile' filepath mode binary = let oflags1 = case mode of ReadMode -> read_flags -#ifdef mingw32_TARGET_OS +#ifdef mingw32_HOST_OS WriteMode -> write_flags .|. o_TRUNC #else WriteMode -> write_flags @@ -818,7 +817,7 @@ openFile' filepath mode binary = -- 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_TARGET_OS +#ifndef mingw32_HOST_OS if mode == WriteMode then throwErrnoIf (/=0) "openFile" (c_ftruncate (fromIntegral fd) 0) @@ -913,7 +912,7 @@ openFd fd mb_fd_type is_socket filepath mode binary = do -- regular files need to be locked RegularFile -> do -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} when (r == -1) $ ioException (IOError Nothing ResourceBusy "openFile" @@ -929,7 +928,7 @@ fdToHandle fd = do openFd fd Nothing False{-XXX!-} fd_str mode True{-bin mode-} -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS foreign import ccall unsafe "lockFile" lockFile :: CInt -> CInt -> CInt -> IO CInt @@ -1039,13 +1038,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) @@ -1055,7 +1052,7 @@ hClose_handle_ handle_ = do -- free the spare buffers writeIORef (haBuffers handle_) BufferListNil -#ifndef mingw32_TARGET_OS +#ifndef mingw32_HOST_OS -- unlock it unlockFile c_fd #endif @@ -1207,7 +1204,7 @@ 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 @@ -1360,7 +1357,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. @@ -1515,26 +1512,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_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 h_ hto_ = do + flushBuffer h_ + new_fd <- throwErrnoIfMinus1 "dupHandleTo" $ + c_dup2 (fromIntegral (haFD hto_)) (fromIntegral (haFD h_)) + 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 @@ -1562,14 +1570,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)