X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=e0b755f1050e2821595f9c3f938c8d2180677b26;hb=ae26ec50a502bbcf454d527e23bfe259fa302ff3;hp=f3008c437a636f097453b90d8ac4780125ca93f9;hpb=002864325037f03891f46044319ed2ccc372f240;p=haskell-directory.git

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index f3008c4..e0b755f 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -594,7 +594,7 @@ writeRawBufferPtr 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
+readRawBufferNoBlock = readRawBuffer
 
 -- Async versions of the read/write primitives, for the non-threaded RTS
 
@@ -813,15 +813,21 @@ openFile' filepath mode binary =
 	      throwErrnoIfMinus1Retry "openFile"
  	        (c_open f (fromIntegral oflags) 0o666)
 
-    h <- openFd fd Nothing False filepath mode binary
+    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
-    if mode == WriteMode
+	-- 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
@@ -909,10 +915,6 @@ openFd fd mb_fd_type is_socket filepath mode binary = do
 	   ioException (IOError Nothing InappropriateType "openFile"
 			   "is a directory" Nothing) 
 
-	Stream
-	   | 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
@@ -923,6 +925,16 @@ openFd fd mb_fd_type is_socket filepath mode binary = do
 #endif
 	   mkFileHandle fd is_socket filepath ha_type binary
 
+	Stream
+	   -- only *Streams* can be DuplexHandles.  Other read/write
+	   -- Handles must share a buffer.
+	   | ReadWriteHandle <- ha_type -> 
+		mkDuplexHandle fd is_socket filepath binary
+	   | otherwise ->
+		mkFileHandle   fd is_socket filepath ha_type binary
+
+	RawDevice -> 
+		mkFileHandle fd is_socket filepath ha_type binary
 
 fdToHandle :: FD -> IO Handle
 fdToHandle fd = do
@@ -957,6 +969,17 @@ mkStdHandle fd filepath ha_type buf bmode = do
 mkFileHandle :: FD -> Bool -> FilePath -> HandleType -> Bool -> IO Handle
 mkFileHandle fd is_stream filepath ha_type binary = do
   (buf, bmode) <- getBuffer fd (initBufferState ha_type)
+
+#ifdef mingw32_HOST_OS
+  -- On Windows, if this is a read/write handle and we are in text mode,
+  -- turn off buffering.  We don't correctly handle the case of switching
+  -- from read mode to write mode on a buffered text-mode handle, see bug
+  -- \#679.
+  bmode <- case ha_type of
+      		ReadWriteHandle | not binary -> return NoBuffering
+		_other			     -> return bmode
+#endif
+
   spares <- newIORef BufferListNil
   newFileHandle filepath (handleFinalizer filepath)
 	    (Handle__ { haFD = fd,
@@ -1140,7 +1163,7 @@ hLookAhead handle = do
 
   -- fill up the read buffer if necessary
   new_buf <- if bufferEmpty buf
-		then fillReadBuffer fd is_line (haIsStream handle_) buf
+		then fillReadBuffer fd True (haIsStream handle_) buf
 		else return buf
   
   writeIORef ref new_buf
@@ -1456,9 +1479,8 @@ hIsSeekable handle =
       SemiClosedHandle 	   -> ioe_closedHandle
       AppendHandle 	   -> return False
       _                    -> do t <- fdType (haFD handle_)
-                                 return (t == RegularFile
-                                         && (haIsBin handle_ 
-						|| tEXT_MODE_SEEK_ALLOWED))
+                                 return ((t == RegularFile    || t == RawDevice)
+                                         && (haIsBin handle_  || tEXT_MODE_SEEK_ALLOWED))
 
 -- -----------------------------------------------------------------------------
 -- Changing echo status (Non-standard GHC extensions)
@@ -1543,9 +1565,10 @@ dupHandle other_side h_ = do
 
 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
+  -- Windows' dup2 does not return the new descriptor, unlike Unix
+  throwErrnoIfMinus1 "dupHandleTo" $ 
+	c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
+  dupHandle_ other_side h_ (haFD hto_)
 
 dupHandle_ other_side h_ new_fd = do
   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))