X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=e826c1ffd3132fdb33aa00e51e54385294686141;hb=a2a70b9bf60672c72b35654105402cf21238b6f4;hp=16a9a2fc9f31e1ea5289d8c153eedbfe4a20feff;hpb=bdcf7efb348fab0c8d398f341d596aa024516a82;p=haskell-directory.git

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 16a9a2f..e826c1f 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -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
 
@@ -77,6 +76,9 @@ import GHC.Enum
 import GHC.Num		( Integer(..), Num(..) )
 import GHC.Show
 import GHC.Real		( toInteger )
+#if defined(DEBUG_DUMP)
+import GHC.Pack
+#endif
 
 import GHC.Conc
 
@@ -155,6 +157,7 @@ withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
 withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
 
+withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
 withHandle_' fun h m act = 
    block $ do
    h_ <- takeMVar m
@@ -374,7 +377,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
@@ -451,7 +454,7 @@ flushReadBuffer fd buf
      puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n")
 #    endif
      throwErrnoIfMinus1Retry "flushReadBuffer"
-   	 (c_lseek (fromIntegral fd) (fromIntegral off) sEEK_CUR)
+   	 (c_lseek fd (fromIntegral off) sEEK_CUR)
      return buf{ bufWPtr=0, bufRPtr=0 }
 
 flushWriteBuffer :: FD -> Bool -> Buffer -> IO Buffer
@@ -464,7 +467,7 @@ flushWriteBuffer fd is_stream buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w }  =
   if bytes == 0
      then return (buf{ bufRPtr=0, bufWPtr=0 })
      else do
-  res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b 
+  res <- writeRawBuffer "flushWriteBuffer" fd is_stream b 
   			(fromIntegral r) (fromIntegral bytes)
   let res' = fromIntegral res
   if res' < bytes 
@@ -513,7 +516,7 @@ fillReadBufferWithoutBlocking fd is_stream
   -- buffer better be empty:
   assert (r == 0 && w == 0) $ do
 #ifdef DEBUG_DUMP
-  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
+  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show size ++ "\n")
 #endif
   res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
   		       0 (fromIntegral size)
@@ -525,7 +528,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
@@ -547,13 +550,13 @@ readRawBufferPtr loc fd is_stream buf off len =
 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 writeRawBuffer loc fd is_stream buf off len = 
   throwErrnoIfMinus1RetryMayBlock loc
-		(write_rawBuffer (fromIntegral fd) buf off len)
+		(write_rawBuffer fd buf off len)
 		(threadWaitWrite (fromIntegral fd))
 
 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 writeRawBufferPtr loc fd is_stream buf off len = 
   throwErrnoIfMinus1RetryMayBlock loc
-		(write_off (fromIntegral fd) buf off len)
+		(write_off fd buf off len)
 		(threadWaitWrite (fromIntegral fd))
 
 foreign import ccall unsafe "__hscore_PrelHandle_read"
@@ -568,7 +571,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
@@ -592,12 +595,12 @@ 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
 
 asyncReadRawBuffer loc fd is_stream buf off len = do
-    (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncReadBA (fromIntegral fd) (if is_stream then 1 else 0) 
 		 (fromIntegral len) off buf
     if l == (-1)
       then 
@@ -605,7 +608,7 @@ asyncReadRawBuffer loc fd is_stream buf off len = do
       else return (fromIntegral l)
 
 asyncReadRawBufferPtr loc fd is_stream buf off len = do
-    (l, rc) <- asyncRead fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncRead (fromIntegral fd) (if is_stream then 1 else 0) 
 			(fromIntegral len) (buf `plusPtr` off)
     if l == (-1)
       then 
@@ -613,7 +616,7 @@ asyncReadRawBufferPtr loc fd is_stream buf off len = do
       else return (fromIntegral l)
 
 asyncWriteRawBuffer loc fd is_stream buf off len = do
-    (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncWriteBA (fromIntegral fd) (if is_stream then 1 else 0) 
 			(fromIntegral len) off buf
     if l == (-1)
       then 
@@ -621,7 +624,7 @@ asyncWriteRawBuffer loc fd is_stream buf off len = do
       else return (fromIntegral l)
 
 asyncWriteRawBufferPtr loc fd is_stream buf off len = do
-    (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) 
+    (l, rc) <- asyncWrite (fromIntegral fd) (if is_stream then 1 else 0) 
 		  (fromIntegral len) (buf `plusPtr` off)
     if l == (-1)
       then 
@@ -646,17 +649,17 @@ blockingReadRawBufferPtr loc fd False buf off len =
 
 blockingWriteRawBuffer loc fd True buf off len = 
   throwErrnoIfMinus1Retry loc $
-    send_rawBuffer (fromIntegral fd) buf off len
+    send_rawBuffer fd buf off len
 blockingWriteRawBuffer loc fd False buf off len = 
   throwErrnoIfMinus1Retry loc $
-    write_rawBuffer (fromIntegral fd) buf off len
+    write_rawBuffer fd buf off len
 
 blockingWriteRawBufferPtr loc fd True buf off len = 
   throwErrnoIfMinus1Retry loc $
-    send_off (fromIntegral fd) buf off len
+    send_off fd buf off len
 blockingWriteRawBufferPtr loc fd False buf off len = 
   throwErrnoIfMinus1Retry loc $
-    write_off (fromIntegral fd) buf off len
+    write_off fd buf off len
 
 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 -- These calls may block, but that's ok.
@@ -787,7 +790,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
@@ -807,21 +810,26 @@ openFile' filepath mode binary =
     -- directories.  However, the man pages I've read say that open()
     -- always returns EISDIR if the file is a directory and was opened
     -- for writing, so I think we're ok with a single open() here...
-    fd <- fromIntegral `liftM`
-	      throwErrnoIfMinus1Retry "openFile"
+    fd <- throwErrnoIfMinus1Retry "openFile"
  	        (c_open f (fromIntegral oflags) 0o666)
 
-    h <- openFd fd Nothing False filepath mode binary
-            `catchException` \e -> do c_close (fromIntegral fd); throw e
+    fd_type <- fdType fd
+
+    h <- openFd fd (Just fd_type) False filepath mode binary
+            `catchException` \e -> do c_close 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_TARGET_OS
-    if mode == WriteMode
+
+#ifndef mingw32_HOST_OS
+	-- 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)
+              (c_ftruncate fd 0)
       else return 0
 #endif
     return h
@@ -865,8 +873,8 @@ openTempFile' loc tmp_dir template binary = do
            then findTempName (x+1)
            else ioError (errnoToIOError loc errno Nothing (Just tmp_dir))
        else do
-         h <- openFd (fromIntegral fd) Nothing False filepath ReadWriteMode True
-	        `catchException` \e -> do c_close (fromIntegral fd); throw e
+         h <- openFd fd Nothing False filepath ReadWriteMode True
+	        `catchException` \e -> do c_close fd; throw e
 	 return (filepath, h)
       where
         filename        = prefix ++ show x ++ suffix
@@ -907,20 +915,26 @@ 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_TARGET_OS
-	   r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
+#ifndef mingw32_HOST_OS
+	   r <- lockFile fd (fromBool write) 1{-exclusive-}
 	   when (r == -1)  $
 		ioException (IOError Nothing ResourceBusy "openFile"
 				   "file is locked" Nothing)
 #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
@@ -929,7 +943,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
 
@@ -955,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,
@@ -1036,26 +1061,25 @@ hClose_help handle_ =
 
 hClose_handle_ handle_ = do
     let fd = haFD handle_
-        c_fd = fromIntegral fd
 
     -- close the file descriptor, but not when this is the read
     -- side of a duplex handle.
     case haOtherSide handle_ of
-      Nothing -> 
+      Nothing ->
   		  throwErrnoIfMinus1Retry_ "hClose" 
-#ifdef mingw32_TARGET_OS
-	    			(closeFd (haIsStream handle_) c_fd)
+#ifdef mingw32_HOST_OS
+	    			(closeFd (haIsStream handle_) fd)
 #else
-	    			(c_close c_fd)
+	    			(c_close fd)
 #endif
       Just _  -> return ()
 
     -- free the spare buffers
     writeIORef (haBuffers handle_) BufferListNil
   
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
     -- unlock it
-    unlockFile c_fd
+    unlockFile fd
 #endif
 
     -- we must set the fd to -1, because the finalizer is going
@@ -1094,7 +1118,7 @@ hSetFileSize handle size =
       SemiClosedHandle 		-> ioe_closedHandle
       _ -> do flushWriteBufferOnly handle_
 	      throwErrnoIf (/=0) "hSetFileSize" 
-	         (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
+	         (c_ftruncate (haFD handle_) (fromIntegral size))
 	      return ()
 
 -- ---------------------------------------------------------------------------
@@ -1138,7 +1162,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
@@ -1205,10 +1229,12 @@ 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
+#else
+		  NoBuffering -> return ()
 #endif
 		  _           -> setCooked (haFD handle_) True
 
@@ -1331,7 +1357,7 @@ hSeek handle mode offset =
 
     let do_seek =
 	  throwErrnoIfMinus1Retry_ "hSeek"
-	    (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence)
+	    (c_lseek (haFD handle_) (fromIntegral offset) whence)
 
         whence :: CInt
         whence = case mode of
@@ -1358,13 +1384,13 @@ 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.
       flushBuffer handle_
 #endif
-      let fd = fromIntegral (haFD handle_)
+      let fd = haFD handle_
       posn <- fromIntegral `liftM`
 	        throwErrnoIfMinus1Retry "hGetPosn"
 		   (c_lseek fd 0 sEEK_CUR)
@@ -1452,9 +1478,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)
@@ -1504,7 +1529,7 @@ hSetBinaryMode :: Handle -> Bool -> IO ()
 hSetBinaryMode handle bin =
   withAllHandles__ "hSetBinaryMode" handle $ \ handle_ ->
     do throwErrnoIfMinus1_ "hSetBinaryMode"
-          (setmode (fromIntegral (haFD handle_)) bin)
+          (setmode (haFD handle_) bin)
        return handle_{haIsBin=bin}
   
 foreign import ccall unsafe "__hscore_setmode"
@@ -1513,31 +1538,48 @@ 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 h 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 h Nothing)
   new_w <- newMVar new_w_
-  new_r_ <- withHandle' "hDuplicate" h r (dupHandle_ (Just new_w))
+  new_r_ <- withHandle' "hDuplicate" h r (dupHandle h (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 :: Handle -> Maybe (MVar Handle__) -> Handle__
+          -> IO (Handle__, Handle__)
+dupHandle h 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 <- case other_side of
+                Nothing -> throwErrnoIfMinus1 "dupHandle" $ c_dup (haFD h_)
+                Just r -> withHandle_' "dupHandle" h r (return . haFD)
+  dupHandle_ other_side h_ new_fd
+
+dupHandleTo other_side hto_ h_ = do
+  flushBuffer h_
+  -- Windows' dup2 does not return the new descriptor, unlike Unix
+  throwErrnoIfMinus1 "dupHandleTo" $ 
+	c_dup2 (haFD h_) (haFD hto_)
+  dupHandle_ other_side h_ (haFD hto_)
+
+dupHandle_ :: Maybe (MVar Handle__) -> Handle__ -> FD
+           -> IO (Handle__, Handle__)
+dupHandle_ other_side h_ new_fd = do
   buffer <- allocateBuffer dEFAULT_BUFFER_SIZE (initBufferState (haType h_))
   ioref <- newIORef buffer
   ioref_buffers <- newIORef BufferListNil
 
-  let new_handle_ = h_{ haFD = fromIntegral new_fd, 
+  let new_handle_ = h_{ haFD = new_fd, 
 	         	haBuffer = ioref, 
 	          	haBuffers = ioref_buffers,
 	          	haOtherSide = other_side }
@@ -1560,14 +1602,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)
@@ -1618,10 +1660,10 @@ showHandle' filepath is_duplex h =
 -- ---------------------------------------------------------------------------
 -- debugging
 
-#ifdef DEBUG_DUMP
+#if defined(DEBUG_DUMP)
 puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
-				     return ()
+puts s = do write_rawBuffer 1 (unsafeCoerce# (packCString# s)) 0 (fromIntegral (length s))
+	    return ()
 #endif
 
 -- -----------------------------------------------------------------------------