From: simonmar <unknown>
Date: Tue, 21 Oct 2003 13:57:39 +0000 (+0000)
Subject: [project @ 2003-10-21 13:57:39 by simonmar]
X-Git-Tag: nhc98-1-18-release~463
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=5ca4b4302f3e41760081ebd1ad9c193d59865698;p=haskell-directory.git

[project @ 2003-10-21 13:57:39 by simonmar]
Fix bug in hGetBufNonBlocking that meant it would sometimes block.
---

diff --git a/GHC/IO.hs b/GHC/IO.hs
index b9b6a23..830889e 100644
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -688,6 +688,7 @@ bufWrite fd ref is_stream ptr count can_block =
 
 	-- 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
@@ -768,7 +769,8 @@ bufRead fd ref is_stream ptr so_far count can_block =
   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
@@ -867,6 +869,103 @@ 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"