X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FHandle.hs;h=f3008c437a636f097453b90d8ac4780125ca93f9;hb=002864325037f03891f46044319ed2ccc372f240;hp=6bbc4397b6eec9e33f8d1841716f4933de1767d0;hpb=8fbc1997264235e4e6d32ba1ac19099eadedb227;p=ghc-base.git

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 6bbc439..f3008c4 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,15 +28,15 @@ module GHC.Handle (
   readRawBuffer, readRawBufferPtr,
   writeRawBuffer, writeRawBufferPtr,
 
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
   unlockFile,
 #endif
 
   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
 
   stdin, stdout, stderr,
-  IOMode(..), openFile, openBinaryFile, openFd, fdToHandle,
-  hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+  IOMode(..), openFile, openBinaryFile, openTempFile, openBinaryTempFile, openFd, fdToHandle,
+  hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
   hFlush, hDuplicate, hDuplicateTo,
 
   hClose, hClose_help,
@@ -54,8 +55,7 @@ module GHC.Handle (
 
  ) where
 
-#include "ghcconfig.h"
-
+import System.Directory.Internals
 import Control.Monad
 import Data.Bits
 import Data.Maybe
@@ -76,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
 
@@ -373,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
@@ -512,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)
@@ -524,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
@@ -567,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
@@ -785,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
@@ -806,19 +813,72 @@ 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
+    h <- openFd fd Nothing 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
+      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
+             -> String     -- ^ File name template. If the template is \"foo.ext\" then
+                           -- the create file will be \"fooXXX.ext\" where XXX is some
+                           -- random number.
+             -> IO (FilePath, Handle)
+openTempFile tmp_dir template = openTempFile' "openTempFile" tmp_dir template dEFAULT_OPEN_IN_BINARY_MODE
+
+-- | Like 'openTempFile', but opens the file in binary mode. See 'openBinaryFile' for more comments.
+openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)
+openBinaryTempFile tmp_dir template = openTempFile' "openBinaryTempFile" tmp_dir template True
+
+openTempFile' :: String -> FilePath -> String -> Bool -> IO (FilePath, Handle)
+openTempFile' loc tmp_dir template binary = do
+  pid <- c_getpid
+  findTempName pid
+  where
+    (prefix,suffix) = break (=='.') template
+
+    oflags1 = rw_flags .|. o_EXCL
+
+    binary_flags
+      | binary    = o_BINARY
+      | otherwise = 0
+
+    oflags = oflags1 .|. binary_flags
+
+    findTempName x = do
+      fd <- withCString filepath $ \ f ->
+              c_open f oflags 0o666
+      if fd < 0 
+       then do
+         errno <- getErrno
+         if errno == eEXIST
+           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
+	 return (filepath, h)
+      where
+        filename        = prefix ++ show x ++ suffix
+        filepath        = tmp_dir `joinFileName` filename
 
 
 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
 
@@ -855,7 +915,7 @@ openFd fd mb_fd_type is_socket filepath mode binary = do
 
 	-- 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"
@@ -871,7 +931,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
 
@@ -981,13 +1041,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)
@@ -997,7 +1055,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
@@ -1009,7 +1067,7 @@ hClose_handle_ handle_ = do
   		   })
 
 -----------------------------------------------------------------------------
--- Detecting the size of a file
+-- Detecting and changing the size of a file
 
 -- | For a handle @hdl@ which attached to a physical file,
 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
@@ -1027,6 +1085,20 @@ hFileSize handle =
 		 else ioException (IOError Nothing InappropriateType "hFileSize"
 				   "not a regular file" Nothing)
 
+
+-- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
+
+hSetFileSize :: Handle -> Integer -> IO ()
+hSetFileSize handle size =
+    withHandle_ "hSetFileSize" handle $ \ handle_ -> do
+    case haType handle_ of 
+      ClosedHandle 		-> ioe_closedHandle
+      SemiClosedHandle 		-> ioe_closedHandle
+      _ -> do flushWriteBufferOnly handle_
+	      throwErrnoIf (/=0) "hSetFileSize" 
+	         (c_ftruncate (fromIntegral (haFD handle_)) (fromIntegral size))
+	      return ()
+
 -- ---------------------------------------------------------------------------
 -- Detecting the End of Input
 
@@ -1135,10 +1207,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
 
@@ -1288,7 +1362,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.
@@ -1443,26 +1517,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
@@ -1490,14 +1575,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)
@@ -1548,10 +1633,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
 
 -- -----------------------------------------------------------------------------