[project @ 2005-01-28 15:03:06 by simonmar]

[ghc-base.git] / GHC / Handle.hs

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index a2dca2c..1db09ff 100644 (file)
--- 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
@@ -27,7 +27,7 @@ module GHC.Handle (
   readRawBuffer, readRawBufferPtr,
   writeRawBuffer, writeRawBufferPtr,
 
-#ifndef mingw32_TARGET_OS
+#ifndef mingw32_HOST_OS
   unlockFile,
 #endif
 
@@ -54,8 +54,7 @@ module GHC.Handle (
 
  ) where
 
-#include "ghcconfig.h"
-
+import System.Directory.Internals
 import Control.Monad
 import Data.Bits
 import Data.Maybe
@@ -63,7 +62,6 @@ import Foreign
 import Foreign.C
 import System.IO.Error
 import System.Posix.Internals
-import System.FilePath
 
 import GHC.Real
 
@@ -374,7 +372,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
@@ -525,7 +523,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 +566,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 +784,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,13 +809,21 @@ 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.
@@ -864,7 +874,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
 
@@ -901,7 +911,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"
@@ -917,7 +927,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 +1037,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 +1051,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
@@ -1195,7 +1203,7 @@ 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
@@ -1348,7 +1356,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.