[project @ 2005-12-13 13:28:53 by simonmar]

[haskell-directory.git] / GHC / Handle.hs

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 2ea5c38..52bf8cd 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -17,6 +17,7 @@
 --
 -----------------------------------------------------------------------------
 
+-- #hide
 module GHC.Handle (
   withHandle, withHandle', withHandle_,
   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
@@ -75,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
 
@@ -511,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)
@@ -809,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
@@ -905,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
@@ -919,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
@@ -1136,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
@@ -1207,6 +1227,8 @@ hSetBuffering handle mode =
        -- '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
 
@@ -1450,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)
@@ -1535,10 +1556,10 @@ dupHandle other_side h_ = do
                c_dup (fromIntegral (haFD h_))
   dupHandle_ other_side h_ new_fd
 
-dupHandleTo other_side h_ hto_ = do
+dupHandleTo other_side hto_ h_ = do
   flushBuffer h_
   new_fd <- throwErrnoIfMinus1 "dupHandleTo" $ 
-               c_dup2 (fromIntegral (haFD hto_)) (fromIntegral (haFD h_))
+               c_dup2 (fromIntegral (haFD h_)) (fromIntegral (haFD hto_))
   dupHandle_ other_side h_ new_fd
 
 dupHandle_ other_side h_ new_fd = do
@@ -1627,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
 
 -- -----------------------------------------------------------------------------