Add tests from testsuite/tests/h98

[ghc-base.git] / GHC / IO / FD.hs

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 32f4e9b..65ed913 100644 (file)
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -1,5 +1,13 @@
-{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-}
+{-# LANGUAGE CPP
+           , NoImplicitPrelude
+           , BangPatterns
+           , ForeignFunctionInterface
+           , DeriveDataTypeable
+  #-}
+{-# OPTIONS_GHC -fno-warn-identities #-}
+-- Whether there are identities depends on the platform

 {-# OPTIONS_HADDOCK hide #-}
 {-# OPTIONS_HADDOCK hide #-}

+

 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.FD
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  GHC.IO.FD

@@ -22,8 +30,6 @@ module GHC.IO.FD (
   stdin, stdout, stderr
   ) where
 
   stdin, stdout, stderr
   ) where
 

-#undef DEBUG_DUMP
-

 import GHC.Base
 import GHC.Num
 import GHC.Real
 import GHC.Base
 import GHC.Num
 import GHC.Real

@@ -39,15 +45,21 @@ import GHC.IO.Buffer
 import GHC.IO.BufferedIO
 import qualified GHC.IO.Device
 import GHC.IO.Device (SeekMode(..), IODeviceType(..))
 import GHC.IO.BufferedIO
 import qualified GHC.IO.Device
 import GHC.IO.Device (SeekMode(..), IODeviceType(..))

-import GHC.Conc
+import GHC.Conc.IO

 import GHC.IO.Exception
 import GHC.IO.Exception

+#ifdef mingw32_HOST_OS
+import GHC.Windows
+#endif

 
 import Foreign
 import Foreign.C
 import qualified System.Posix.Internals
 import System.Posix.Internals hiding (FD, setEcho, getEcho)
 import System.Posix.Types
 
 import Foreign
 import Foreign.C
 import qualified System.Posix.Internals
 import System.Posix.Internals hiding (FD, setEcho, getEcho)
 import System.Posix.Types

-import GHC.Ptr
+-- import GHC.Ptr
+
+c_DEBUG_DUMP :: Bool
+c_DEBUG_DUMP = False

 
 -- -----------------------------------------------------------------------------
 -- The file-descriptor IO device
 
 -- -----------------------------------------------------------------------------
 -- The file-descriptor IO device

@@ -97,8 +109,15 @@ instance GHC.IO.Device.IODevice FD where
   dup           = dup
   dup2          = dup2
 
   dup           = dup
   dup2          = dup2
 

+-- We used to use System.Posix.Internals.dEFAULT_BUFFER_SIZE, which is
+-- taken from the value of BUFSIZ on the current platform.  This value
+-- varies too much though: it is 512 on Windows, 1024 on OS X and 8192
+-- on Linux.  So let's just use a decent size on every platform:
+dEFAULT_FD_BUFFER_SIZE :: Int
+dEFAULT_FD_BUFFER_SIZE = 8096
+

 instance BufferedIO FD where
 instance BufferedIO FD where

-  newBuffer _dev state = newByteBuffer dEFAULT_BUFFER_SIZE state
+  newBuffer _dev state = newByteBuffer dEFAULT_FD_BUFFER_SIZE state

   fillReadBuffer    fd buf = readBuf' fd buf
   fillReadBuffer0   fd buf = readBufNonBlocking fd buf
   flushWriteBuffer  fd buf = writeBuf' fd buf
   fillReadBuffer    fd buf = readBuf' fd buf
   fillReadBuffer0   fd buf = readBufNonBlocking fd buf
   flushWriteBuffer  fd buf = writeBuf' fd buf

@@ -106,30 +125,31 @@ instance BufferedIO FD where
 
 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
 readBuf' fd buf = do
 
 readBuf' :: FD -> Buffer Word8 -> IO (Int, Buffer Word8)
 readBuf' fd buf = do

-#ifdef DEBUG_DUMP
-  puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
-#endif
+  when c_DEBUG_DUMP $
+      puts ("readBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")

   (r,buf') <- readBuf fd buf
   (r,buf') <- readBuf fd buf

-#ifdef DEBUG_DUMP
-  puts ("after: " ++ summaryBuffer buf' ++ "\n")
-#endif
+  when c_DEBUG_DUMP $
+      puts ("after: " ++ summaryBuffer buf' ++ "\n")

   return (r,buf')
 
   return (r,buf')
 

-writeBuf' :: FD -> Buffer Word8 -> IO ()
+writeBuf' :: FD -> Buffer Word8 -> IO (Buffer Word8)

 writeBuf' fd buf = do
 writeBuf' fd buf = do

-#ifdef DEBUG_DUMP
-  puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")
-#endif
+  when c_DEBUG_DUMP $
+      puts ("writeBuf fd=" ++ show fd ++ " " ++ summaryBuffer buf ++ "\n")

   writeBuf fd buf
 
 -- -----------------------------------------------------------------------------
 -- opening files
 
 -- | Open a file and make an 'FD' for it.  Truncates the file to zero
   writeBuf fd buf
 
 -- -----------------------------------------------------------------------------
 -- opening files
 
 -- | Open a file and make an 'FD' for it.  Truncates the file to zero

--- size when the `IOMode` is `WriteMode`.  Puts the file descriptor
--- into non-blocking mode on Unix systems.
-openFile :: FilePath -> IOMode -> IO (FD,IODeviceType)
-openFile filepath iomode =
+-- size when the `IOMode` is `WriteMode`.
+openFile
+  :: FilePath -- ^ file to open
+  -> IOMode   -- ^ mode in which to open the file
+  -> Bool     -- ^ open the file in non-blocking mode?
+  -> IO (FD,IODeviceType)
+
+openFile filepath iomode non_blocking =

   withFilePath filepath $ \ f ->
 
     let 
   withFilePath filepath $ \ f ->
 
     let 

@@ -149,7 +169,10 @@ openFile filepath iomode =
       binary_flags = 0
 #endif      
 
       binary_flags = 0
 #endif      
 

-      oflags = oflags1 .|. binary_flags
+      oflags2 = oflags1 .|. binary_flags
+
+      oflags | non_blocking = oflags2 .|. nonblock_flags
+             | otherwise    = oflags2

     in do
 
     -- the old implementation had a complicated series of three opens,
     in do
 
     -- the old implementation had a complicated series of three opens,

@@ -158,12 +181,14 @@ openFile filepath iomode =
     -- 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 <- throwErrnoIfMinus1Retry "openFile"
     -- 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 <- throwErrnoIfMinus1Retry "openFile"

-                (c_open f (fromIntegral oflags) 0o666)
+                (if non_blocking then c_open      f oflags 0o666
+                                 else c_safe_open f oflags 0o666)

 
     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                             False{-not a socket-} 
 
     (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-}
                             False{-not a socket-} 

-                            True{-is non-blocking-}
-            `catchAny` \e -> do c_close fd; throwIO e
+                            non_blocking
+            `catchAny` \e -> do _ <- c_close fd
+                                throwIO e

 
 #ifndef mingw32_HOST_OS
         -- we want to truncate() if this is an open in WriteMode, but only
 
 #ifndef mingw32_HOST_OS
         -- we want to truncate() if this is an open in WriteMode, but only

@@ -177,13 +202,14 @@ openFile filepath iomode =
     return (fD,fd_type)
 
 std_flags, output_flags, read_flags, write_flags, rw_flags,
     return (fD,fd_type)
 
 std_flags, output_flags, read_flags, write_flags, rw_flags,

-    append_flags :: CInt
-std_flags    = o_NONBLOCK   .|. o_NOCTTY
+    append_flags, nonblock_flags :: CInt
+std_flags    = o_NOCTTY

 output_flags = std_flags    .|. o_CREAT
 read_flags   = std_flags    .|. o_RDONLY 
 write_flags  = output_flags .|. o_WRONLY
 rw_flags     = output_flags .|. o_RDWR
 append_flags = write_flags  .|. o_APPEND
 output_flags = std_flags    .|. o_CREAT
 read_flags   = std_flags    .|. o_RDONLY 
 write_flags  = output_flags .|. o_WRONLY
 rw_flags     = output_flags .|. o_RDWR
 append_flags = write_flags  .|. o_APPEND

+nonblock_flags = o_NONBLOCK

 
 
 -- | Make a 'FD' from an existing file descriptor.  Fails if the FD
 
 
 -- | Make a 'FD' from an existing file descriptor.  Fails if the FD

@@ -216,7 +242,7 @@ mkFD fd iomode mb_stat is_socket is_nonblock = do
                    _ -> True
 
 #ifdef mingw32_HOST_OS
                    _ -> True
 
 #ifdef mingw32_HOST_OS

-    setmode fd True -- unconditionally set binary mode
+    _ <- setmode fd True -- unconditionally set binary mode

     let _ = (dev,ino,write) -- warning suppression
 #endif
 
     let _ = (dev,ino,write) -- warning suppression
 #endif
 

@@ -279,23 +305,25 @@ stderr = stdFD 2
 close :: FD -> IO ()
 close fd =
 #ifndef mingw32_HOST_OS
 close :: FD -> IO ()
 close fd =
 #ifndef mingw32_HOST_OS

-  (flip finally) (release fd) $ do
+  (flip finally) (release fd) $

 #endif
 #endif

-  throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $
+  do let closer realFd =
+           throwErrnoIfMinus1Retry_ "GHC.IO.FD.close" $

 #ifdef mingw32_HOST_OS
 #ifdef mingw32_HOST_OS

-    if fdIsSocket fd then
-       c_closesocket (fdFD fd)
-    else
+           if fdIsSocket fd then
+             c_closesocket (fromIntegral realFd)
+           else

 #endif
 #endif

-       c_close (fdFD fd)
+             c_close (fromIntegral realFd)
+     closeFdWith closer (fromIntegral (fdFD fd))

 
 release :: FD -> IO ()
 
 release :: FD -> IO ()

-release fd = do
-#ifndef mingw32_HOST_OS
-   unlockFile (fdFD fd)
+#ifdef mingw32_HOST_OS
+release _ = return ()
+#else
+release fd = do _ <- unlockFile (fdFD fd)
+                return ()

 #endif
 #endif

-   let _ = fd -- warning suppression
-   return ()

 
 #ifdef mingw32_HOST_OS
 foreign import stdcall unsafe "HsBase.h closesocket"
 
 #ifdef mingw32_HOST_OS
 foreign import stdcall unsafe "HsBase.h closesocket"

@@ -309,9 +337,8 @@ isSeekable fd = do
 
 seek :: FD -> SeekMode -> Integer -> IO ()
 seek fd mode off = do
 
 seek :: FD -> SeekMode -> Integer -> IO ()
 seek fd mode off = do

-  throwErrnoIfMinus1Retry "seek" $
+  throwErrnoIfMinus1Retry_ "seek" $

      c_lseek (fdFD fd) (fromIntegral off) seektype
      c_lseek (fdFD fd) (fromIntegral off) seektype

-  return ()

  where
     seektype :: CInt
     seektype = case mode of
  where
     seektype :: CInt
     seektype = case mode of

@@ -330,9 +357,8 @@ getSize fd = fdFileSize (fdFD fd)
 
 setSize :: FD -> Integer -> IO () 
 setSize fd size = do
 
 setSize :: FD -> Integer -> IO () 
 setSize fd size = do

-  throwErrnoIf (/=0) "GHC.IO.FD.setSize"  $
+  throwErrnoIf_ (/=0) "GHC.IO.FD.setSize"  $

      c_ftruncate (fdFD fd) (fromIntegral size)
      c_ftruncate (fdFD fd) (fromIntegral size)

-  return ()

 
 devType :: FD -> IO IODeviceType
 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty
 
 devType :: FD -> IO IODeviceType
 devType fd = do (ty,_,_) <- fdStat (fdFD fd); return ty

@@ -345,7 +371,7 @@ dup fd = do
 dup2 :: FD -> FD -> IO FD
 dup2 fd fdto = do
   -- Windows' dup2 does not return the new descriptor, unlike Unix
 dup2 :: FD -> FD -> IO FD
 dup2 fd fdto = do
   -- Windows' dup2 does not return the new descriptor, unlike Unix

-  throwErrnoIfMinus1 "GHC.IO.FD.dup2" $ 
+  throwErrnoIfMinus1_ "GHC.IO.FD.dup2" $

     c_dup2 (fdFD fd) (fdFD fdto)
   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 
     c_dup2 (fdFD fd) (fdFD fdto)
   return fd{ fdFD = fdFD fdto } -- original FD, with the new fdFD
 

@@ -377,7 +403,12 @@ foreign import ccall safe "fdReady"
 -- Terminal-related stuff
 
 isTerminal :: FD -> IO Bool
 -- Terminal-related stuff
 
 isTerminal :: FD -> IO Bool

-isTerminal fd = c_isatty (fdFD fd) >>= return.toBool
+isTerminal fd =
+#if defined(mingw32_HOST_OS)
+    is_console (fdFD fd) >>= return.toBool
+#else
+    c_isatty (fdFD fd) >>= return.toBool
+#endif

 
 setEcho :: FD -> Bool -> IO () 
 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on
 
 setEcho :: FD -> Bool -> IO () 
 setEcho fd on = System.Posix.Internals.setEcho (fdFD fd) on

@@ -392,17 +423,17 @@ setRaw fd raw = System.Posix.Internals.setCooked (fdFD fd) (not raw)
 -- Reading and Writing
 
 fdRead :: FD -> Ptr Word8 -> Int -> IO Int
 -- Reading and Writing
 
 fdRead :: FD -> Ptr Word8 -> Int -> IO Int

-fdRead fd ptr bytes = do
-  r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
-  return (fromIntegral r)
+fdRead fd ptr bytes
+  = do { r <- readRawBufferPtr "GHC.IO.FD.fdRead" fd ptr 0 (fromIntegral bytes)
+       ; return (fromIntegral r) }

 
 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
 fdReadNonBlocking fd ptr bytes = do
   r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 
            0 (fromIntegral bytes)
 
 fdReadNonBlocking :: FD -> Ptr Word8 -> Int -> IO (Maybe Int)
 fdReadNonBlocking fd ptr bytes = do
   r <- readRawBufferPtrNoBlock "GHC.IO.FD.fdReadNonBlocking" fd ptr 
            0 (fromIntegral bytes)

-  case r of
+  case fromIntegral r of

     (-1) -> return (Nothing)
     (-1) -> return (Nothing)

-    n    -> return (Just (fromIntegral n))
+    n    -> return (Just n)

 
 
 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()
 
 
 fdWrite :: FD -> Ptr Word8 -> Int -> IO ()

@@ -580,7 +611,16 @@ blockingWriteRawBufferPtr loc fd buf off len
   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
         if fdIsSocket fd
            then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0
   = fmap fromIntegral $ throwErrnoIfMinus1Retry loc $
         if fdIsSocket fd
            then c_safe_send  (fdFD fd) (buf `plusPtr` off) len 0

-           else c_safe_write (fdFD fd) (buf `plusPtr` off) len
+           else do
+             r <- c_safe_write (fdFD fd) (buf `plusPtr` off) len
+             when (r == -1) c_maperrno
+             return r
+      -- we don't trust write() to give us the correct errno, and
+      -- instead do the errno conversion from GetLastError()
+      -- ourselves.  The main reason is that we treat ERROR_NO_DATA
+      -- (pipe is closing) as EPIPE, whereas write() returns EINVAL
+      -- for this case.  We need to detect EPIPE correctly, because it
+      -- shouldn't be reported as an error when it happens on stdout.

 
 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 -- These calls may block, but that's ok.
 
 -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS.
 -- These calls may block, but that's ok.

@@ -624,9 +664,3 @@ foreign import ccall unsafe "lockFile"
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
 #endif
 foreign import ccall unsafe "unlockFile"
   unlockFile :: CInt -> IO CInt
 #endif

-
-#if defined(DEBUG_DUMP)
-puts :: String -> IO ()
-puts s = do withCStringLen s $ \(p,len) -> c_write 1 p (fromIntegral len)
-            return ()
-#endif