Add GHC.IO.Handle.FD.openFileBlocking (#4248)

like openFile, but opens the file without O_NONBLOCK

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index b5392d4..012bb73 100644 (file)
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -141,8 +141,8 @@ writeBuf' fd buf = do
 -- | 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 =
+openFile :: FilePath -> IOMode -> Bool -> IO (FD,IODeviceType)
+openFile filepath iomode non_blocking =
   withFilePath filepath $ \ f ->
 
     let 
@@ -162,7 +162,10 @@ openFile filepath iomode =
       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,
@@ -171,11 +174,12 @@ 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"
-                (c_open f 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-} 
-                            True{-is non-blocking-}
+                            non_blocking
             `catchAny` \e -> do _ <- c_close fd
                                 throwIO e
 
@@ -191,13 +195,14 @@ openFile filepath iomode =
     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
+nonblock_flags = o_NONBLOCK
 
 
 -- | Make a 'FD' from an existing file descriptor.  Fails if the FD

diff --git a/GHC/IO/Handle/FD.hs b/GHC/IO/Handle/FD.hs
index 4c380d6..b61c641 100644 (file)
--- a/GHC/IO/Handle/FD.hs
+++ b/GHC/IO/Handle/FD.hs
@@ -16,7 +16,7 @@
 
 module GHC.IO.Handle.FD ( 
   stdin, stdout, stderr,
-  openFile, openBinaryFile,
+  openFile, openBinaryFile, openFileBlocking,
   mkHandleFromFD, fdToHandle, fdToHandle',
   isEOF
  ) where
@@ -148,7 +148,17 @@ addFilePathToIOError fun fp ioe
 openFile :: FilePath -> IOMode -> IO Handle
 openFile fp im = 
   catchException
-    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE)
+    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True)
+    (\e -> ioError (addFilePathToIOError "openFile" fp e))
+
+-- | Like 'openFile', but opens the file in ordinary blocking mode.
+-- This can be useful for opening a FIFO for reading: if we open in
+-- non-blocking mode then the open will fail if there are no writers,
+-- whereas a blocking open will block until a writer appears.
+openFileBlocking :: FilePath -> IOMode -> IO Handle
+openFileBlocking fp im =
+  catchException
+    (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False)
     (\e -> ioError (addFilePathToIOError "openFile" fp e))
 
 -- | Like 'openFile', but open the file in binary mode.
@@ -163,18 +173,20 @@ openFile fp im =
 openBinaryFile :: FilePath -> IOMode -> IO Handle
 openBinaryFile fp m =
   catchException
-    (openFile' fp m True)
+    (openFile' fp m True True)
     (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e))
 
-openFile' :: String -> IOMode -> Bool -> IO Handle
-openFile' filepath iomode binary = do
+openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle
+openFile' filepath iomode binary non_blocking = do
   -- first open the file to get an FD
-  (fd, fd_type) <- FD.openFile filepath iomode
+  (fd, fd_type) <- FD.openFile filepath iomode non_blocking
 
   let mb_codec = if binary then Nothing else Just localeEncoding
 
   -- then use it to make a Handle
-  mkHandleFromFD fd fd_type filepath iomode True{-non-blocking-} mb_codec
+  mkHandleFromFD fd fd_type filepath iomode
+                   False {- do not *set* non-blocking mode -}
+                   mb_codec
             `onException` IODevice.close fd
         -- NB. don't forget to close the FD if mkHandleFromFD fails, otherwise
         -- this FD leaks.
@@ -189,9 +201,9 @@ openFile' filepath iomode binary = do
 mkHandleFromFD
    :: FD
    -> IODeviceType
-   -> FilePath -- a string describing this file descriptor (e.g. the filename)
+   -> FilePath  -- a string describing this file descriptor (e.g. the filename)
    -> IOMode
-   -> Bool -- non_blocking (*sets* non-blocking mode on the FD)
+   -> Bool      -- *set* non-blocking mode on the FD
    -> Maybe TextEncoding
    -> IO Handle
 

diff --git a/System/Posix/Internals.hs b/System/Posix/Internals.hs
index 2a6126c..9cc56c3 100644 (file)
--- a/System/Posix/Internals.hs
+++ b/System/Posix/Internals.hs
@@ -396,6 +396,9 @@ foreign import ccall unsafe "HsBase.h __hscore_lstat"
 foreign import ccall unsafe "HsBase.h __hscore_open"
    c_open :: CFilePath -> CInt -> CMode -> IO CInt
 
+foreign import ccall safe "HsBase.h __hscore_open"
+   c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt
+
 foreign import ccall unsafe "HsBase.h read" 
    c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize