-{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
#undef DEBUG_DUMP
#undef DEBUG
--
-----------------------------------------------------------------------------
+-- #hide
module GHC.Handle (
withHandle, withHandle', withHandle_,
wantWritableHandle, wantReadableHandle, wantSeekableHandle,
readRawBuffer, readRawBufferPtr,
writeRawBuffer, writeRawBufferPtr,
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
unlockFile,
#endif
) where
-#include "ghcconfig.h"
-
+import System.Directory.Internals
import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign.C
import System.IO.Error
import System.Posix.Internals
-import System.FilePath
import GHC.Real
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
-- 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
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
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
-- 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)
-- 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"
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
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)
-- free the spare buffers
writeIORef (haBuffers handle_) BufferListNil
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
-- unlock it
unlockFile c_fd
#endif
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
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.
-- -----------------------------------------------------------------------------
-- 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
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)