-- else, we have to flush
else do flushed_buf <- flushWriteBuffer fd is_stream old_buf
+ -- TODO: we should do a non-blocking flush here
writeIORef ref flushed_buf
-- if we can fit in the buffer, then just loop
if count < size
else if can_block
then do writeChunk fd is_stream (castPtr ptr) count
return count
- else writeChunkNonBlocking fd ptr count
+ else writeChunkNonBlocking fd is_stream ptr count
writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO ()
writeChunk fd is_stream ptr bytes = loop 0 bytes
-- write can't return 0
loop (off + r) (bytes - r)
-writeChunkNonBlocking :: FD -> Ptr a -> Int -> IO Int
-writeChunkNonBlocking fd ptr bytes = loop 0 bytes
+writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
+writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes
where
loop :: Int -> Int -> IO Int
loop off bytes | bytes <= 0 = return off
loop off bytes = do
+#ifndef mingw32_TARGET_OS
ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
let r = fromIntegral ssize :: Int
if (r == -1)
then return off
else throwErrno "writeChunk"
else loop (off + r) (bytes - r)
+#else
+ (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream)
+ (fromIntegral bytes)
+ (ptr `plusPtr` off)
+ let r = fromIntegral ssize :: Int
+ if r == (-1)
+ then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
+ else loop (off + r) (bytes - r)
+#endif
-- ---------------------------------------------------------------------------
-- hGetBuf
seq fd $ seq so_far $ seq count $ do -- strictness hack
buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref
if bufferEmpty buf
- then if count < sz
+ then if so_far > 0 then return so_far else
+ if count < sz
then do
mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf
case mb_buf of
loop :: Int -> Int -> IO Int
loop off bytes | bytes <= 0 = return off
loop off bytes = do
+#ifndef mingw32_TARGET_OS
ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes)
let r = fromIntegral ssize :: Int
if (r == -1)
else if (r == 0)
then return off
else loop (off + r) (bytes - r)
+#else
+ (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream)
+ (fromIntegral bytes)
+ (ptr `plusPtr` off)
+ let r = fromIntegral ssize :: Int
+ if r == (-1)
+ then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing)
+ else if (r == 0)
+ then return off
+ else loop (off + r) (bytes - r)
+#endif
slurpFile :: FilePath -> IO (Ptr (), Int)
slurpFile fname = do
return (chunk, r)
-- ---------------------------------------------------------------------------
+-- pipes
+
+{-|
+(@createPipe@) creates an anonymous /pipe/ and returns a pair of
+handles, the first for reading and the second for writing. Both
+pipe ends can be inherited by a child process.
+
+> createPipe = createPipeEx (BinaryMode AppendMode)
+-}
+createPipe :: IO (Handle,Handle)
+createPipe = createPipeEx AppendMode
+
+{-|
+(@createPipeEx modeEx@) creates an anonymous /pipe/ and returns a pair of
+handles, the first for reading and the second for writing.
+The pipe mode @modeEx@ can be:
+
+ * @'TextMode' mode@ -- the pipe is opened in text mode.
+
+ * @'BinaryMode' mode@ -- the pipe is opened in binary mode.
+
+The @mode@ determines if child processes can inherit the pipe handles:
+
+ * 'ReadMode' -- The /read/ handle of the pipe is private to this process.
+
+ * 'WriteMode' -- The /write/ handle of the pipe is private to this process.
+
+ * 'ReadWriteMode' -- Both handles are private to this process.
+
+ * 'AppendMode' -- Both handles are available (inheritable) to child processes.
+ This mode can be used to /append/ (|) two seperate child processes.
+
+If a broken pipe is read, an end-of-file ('GHC.IOBase.EOF')
+exception is raised. If a broken pipe is written to, an invalid argument exception
+is raised ('GHC.IOBase.InvalidArgument').
+-}
+createPipeEx :: IOMode -> IO (Handle,Handle)
+createPipeEx mode = do
+#if 1
+ return (error "createPipeEx")
+#else
+
+#ifndef mingw32_TARGET_OS
+ -- ignore modeEx for Unix: just always inherit the descriptors
+ allocaArray 2 $ \p -> do
+ throwErrnoIfMinus1 "createPipe" (c_pipe p)
+ r <- peekElemOff p 0
+ hr <- openFd (fromIntegral r) (Just Stream) ("<fd="++show r++")>") ReadMode
+ False{-text mode-} False{-don't truncate-}
+ w <- peekElemOff p 1
+ hw <- openFd (fromIntegral w) (Just Stream) ("<fd="++show r++")>") WriteMode
+ False{-text mode-} False{-don't truncate-}
+ return (hr,hw)
+#else
+
+ alloca $ \pFdRead ->
+ alloca $ \pFdWrite ->
+ do{ r <- winCreatePipe (fromIntegral textmode) (fromIntegral inherit) 4096 pFdRead pFdWrite
+ ; when (r/=0) (ioError (userError ("unable to create pipe")))
+ ; fdRead <- do{ fd <- peek pFdRead
+ ; case mode of
+ WriteMode -> inheritFd fd -- a child process must be able to read from it
+ other -> return fd
+ }
+ ; fdWrite <- do{ fd <- peek pFdWrite
+ ; case mode of
+ ReadMode -> inheritFd fd -- a child process must be able to write to it
+ other -> return fd
+ }
+ ; hRead <- openFd (fromIntegral fd) (Just Stream)
+ "<pipe(read)>" ReadMode textmode False
+ ; hWrite <- openFd (fromIntegral fd) (Just Stream)
+ "<pipe(write)>" WriteMode textmode False
+ ; return (hRead,hWrite)
+ }
+ where
+ (mode,textmode) = case modeEx of
+ TextMode mode -> (mode,1::Int)
+ BinaryMode mode -> (mode,0::Int)
+
+ inherit :: Int
+ inherit = case mode of
+ ReadMode -> 0 -- not inheritable
+ WriteMode -> 0 -- not inheritable
+ ReadWriteMode -> 0 -- not inheritable
+ AppendMode -> 1 -- both inheritable
+
+inheritFd :: CInt -> IO CInt
+inheritFd fd0
+ = do{ fd1 <- c_dup fd0 -- dup() makes a file descriptor inheritable
+ ; c_close fd0
+ ; return fd1
+ }
+#endif
+#endif /* mingw32_TARGET_OS */
+
+-- ---------------------------------------------------------------------------
-- memcpy wrappers
foreign import ccall unsafe "__hscore_memcpy_src_off"
projects / ghc-base.git / blobdiff