X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=52bf8cde99e4de0877b07139144ee74ea924c067;hb=b674b3cdb447d2265dccc4e3c343c9625f464a33;hp=a2dca2c655af49087327fc54114fb11b9f8a0bc2;hpb=7bce4ee1aa0287c9885647dfcf9de5072492a3fb;p=haskell-directory.git

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index a2dca2c..52bf8cd 100644
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
 
 #undef DEBUG_DUMP
 #undef DEBUG
@@ -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
 
@@ -374,7 +376,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
@@ -513,7 +515,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 +527,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
@@ -568,7 +570,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
@@ -786,9 +788,13 @@ openFile' filepath mode binary =
 
     let 
       oflags1 = case mode of
-	    	  ReadMode      -> read_flags  
-	    	  WriteMode     -> write_flags 
-	    	  ReadWriteMode -> rw_flags    
+	    	  ReadMode      -> read_flags
+#ifdef mingw32_HOST_OS
+	    	  WriteMode     -> write_flags .|. o_TRUNC
+#else
+	    	  WriteMode     -> write_flags
+#endif
+	    	  ReadWriteMode -> rw_flags
 	    	  AppendMode    -> append_flags
 
       binary_flags
@@ -807,14 +813,28 @@ openFile' filepath mode binary =
 	      throwErrnoIfMinus1Retry "openFile"
  	        (c_open f (fromIntegral oflags) 0o666)
 
-    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 (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
+	-- 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
+#endif
+    return h
+
+
 -- | The function creates a temporary file in ReadWrite mode.
 -- The created file isn\'t deleted automatically, so you need to delete it manually.
 openTempFile :: FilePath   -- ^ Directory in which to create the file
@@ -864,7 +884,7 @@ openTempFile' loc tmp_dir template binary = do
 std_flags    = o_NONBLOCK   .|. o_NOCTTY
 output_flags = std_flags    .|. o_CREAT
 read_flags   = std_flags    .|. o_RDONLY 
-write_flags  = output_flags .|. o_WRONLY .|. o_TRUNC
+write_flags  = output_flags .|. o_WRONLY
 rw_flags     = output_flags .|. o_RDWR
 append_flags = write_flags  .|. o_APPEND
 
@@ -895,13 +915,9 @@ 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
+#ifndef mingw32_HOST_OS
 	   r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-}
 	   when (r == -1)  $
 		ioException (IOError Nothing ResourceBusy "openFile"
@@ -909,6 +925,20 @@ 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
+
+	_ ->
+	  ioException (IOError Nothing UnsupportedOperation "openFd"
+			           "unknown file type" Nothing) 
 
 fdToHandle :: FD -> IO Handle
 fdToHandle fd = do
@@ -917,7 +947,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
 
@@ -1027,13 +1057,11 @@ hClose_handle_ handle_ = do
         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)
@@ -1043,7 +1071,7 @@ hClose_handle_ handle_ = do
     -- free the spare buffers
     writeIORef (haBuffers handle_) BufferListNil
   
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
     -- unlock it
     unlockFile c_fd
 #endif
@@ -1128,7 +1156,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
@@ -1195,10 +1223,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
 
@@ -1348,7 +1378,7 @@ 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.
@@ -1442,9 +1472,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)
@@ -1503,26 +1532,37 @@ 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 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 hto_ h_ = do
+  flushBuffer h_
+  new_fd <- throwErrnoIfMinus1 "dupHandleTo" $ 
+	        c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
+  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
@@ -1550,14 +1590,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)
@@ -1608,10 +1648,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
 
 -- -----------------------------------------------------------------------------