[project @ 2004-02-12 14:55:31 by simonpj]

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

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index d1f026c..8f0e50d 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -22,15 +22,12 @@ module GHC.Handle (
   wantWritableHandle, wantReadableHandle, wantSeekableHandle,
   
   newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
-  flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
+  flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, 
+  fillReadBuffer, fillReadBufferWithoutBlocking,
   readRawBuffer, readRawBufferPtr,
   writeRawBuffer, writeRawBufferPtr,
   unlockFile,
   
-  {- ought to be unnecessary, but just in case.. -}
-  write_off, write_rawBuffer,
-  read_off,  read_rawBuffer,
-
   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
 
   stdin, stdout, stderr,
@@ -493,44 +490,66 @@ fillReadBufferLoop fd is_line is_stream buf b w size = do
             else return buf{ bufRPtr=0, bufWPtr=w+res' }
  
 
+fillReadBufferWithoutBlocking :: FD -> Bool -> Buffer -> IO Buffer
+fillReadBufferWithoutBlocking fd is_stream
+      buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
+  -- buffer better be empty:
+  assert (r == 0 && w == 0) $ do
+#ifdef DEBUG_DUMP
+  puts ("fillReadBufferLoopNoBlock: bytes = " ++ show bytes ++ "\n")
+#endif
+  res <- readRawBufferNoBlock "fillReadBuffer" fd is_stream b
+                      0 (fromIntegral size)
+  let res' = fromIntegral res
+#ifdef DEBUG_DUMP
+  puts ("fillReadBufferLoopNoBlock:  res' = " ++ show res' ++ "\n")
+#endif
+  return buf{ bufRPtr=0, bufWPtr=res' }
+ 
 -- Low level routines for reading/writing to (raw)buffers:
 
 #ifndef mingw32_TARGET_OS
 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 readRawBuffer loc fd is_stream buf off len = 
   throwErrnoIfMinus1RetryMayBlock loc
-           (read_rawBuffer fd is_stream buf off len)
+           (read_rawBuffer fd buf off len)
            (threadWaitRead fd)
 
+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBufferNoBlock loc fd is_stream buf off len = 
+  throwErrnoIfMinus1RetryOnBlock loc
+           (read_rawBuffer fd buf off len)
+           (return 0)
+
 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 readRawBufferPtr loc fd is_stream buf off len = 
   throwErrnoIfMinus1RetryMayBlock loc
-           (read_off fd is_stream buf off len)
+           (read_off fd buf off len)
            (threadWaitRead fd)
 
 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 writeRawBuffer loc fd is_stream buf off len = 
   throwErrnoIfMinus1RetryMayBlock loc
-               (write_rawBuffer (fromIntegral fd) is_stream buf off len)
+               (write_rawBuffer (fromIntegral fd) buf off len)
                (threadWaitWrite fd)
 
 writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 writeRawBufferPtr loc fd is_stream buf off len = 
   throwErrnoIfMinus1RetryMayBlock loc
-               (write_off (fromIntegral fd) is_stream buf off len)
+               (write_off (fromIntegral fd) buf off len)
                (threadWaitWrite fd)
 
 foreign import ccall unsafe "__hscore_PrelHandle_read"
-   read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+   read_rawBuffer :: FD -> RawBuffer -> Int -> CInt -> IO CInt
 
 foreign import ccall unsafe "__hscore_PrelHandle_read"
-   read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+   read_off :: FD -> Ptr CChar -> Int -> CInt -> IO CInt
 
 foreign import ccall unsafe "__hscore_PrelHandle_write"
-   write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+   write_rawBuffer :: CInt -> RawBuffer -> Int -> CInt -> IO CInt
 
 foreign import ccall unsafe "__hscore_PrelHandle_write"
-   write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+   write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
 
 #else
 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
@@ -541,6 +560,14 @@ readRawBuffer loc fd is_stream buf off len = do
     ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
     else return (fromIntegral l)
 
+readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBufferNoBlock loc fd is_stream buf off len = do
+  (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
+  if l == (-1)
+   then 
+    ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+    else return (fromIntegral l)
+
 readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
 readRawBufferPtr loc fd is_stream buf off len = do
   (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
@@ -564,19 +591,6 @@ writeRawBufferPtr loc fd is_stream buf off len = do
    then 
     ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
     else return (fromIntegral l)
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
-   read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_read"
-   read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
-   write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
-   write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
 #endif
 
 -- ---------------------------------------------------------------------------
@@ -1276,7 +1290,7 @@ hIsSeekable handle =
 -- -----------------------------------------------------------------------------
 -- Changing echo status (Non-standard GHC extensions)
 
--- | Set the echoing status of a handle connected to a terminal (GHC only).
+-- | Set the echoing status of a handle connected to a terminal.
 
 hSetEcho :: Handle -> Bool -> IO ()
 hSetEcho handle on = do
@@ -1289,7 +1303,7 @@ hSetEcho handle on = do
          ClosedHandle -> ioe_closedHandle
          _            -> setEcho (haFD handle_) on
 
--- | Get the echoing status of a handle connected to a terminal (GHC only).
+-- | Get the echoing status of a handle connected to a terminal.
 
 hGetEcho :: Handle -> IO Bool
 hGetEcho handle = do
@@ -1302,7 +1316,7 @@ hGetEcho handle = do
          ClosedHandle -> ioe_closedHandle
          _            -> getEcho (haFD handle_)
 
--- | Is the handle connected to a terminal? (GHC only)
+-- | Is the handle connected to a terminal?
 
 hIsTerminalDevice :: Handle -> IO Bool
 hIsTerminalDevice handle = do
@@ -1442,6 +1456,23 @@ puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegra
 #endif
 
 -- -----------------------------------------------------------------------------
+-- utils
+
+throwErrnoIfMinus1RetryOnBlock  :: String -> IO CInt -> IO CInt -> IO CInt
+throwErrnoIfMinus1RetryOnBlock loc f on_block  = 
+  do
+    res <- f
+    if (res :: CInt) == -1
+      then do
+       err <- getErrno
+       if err == eINTR
+         then throwErrnoIfMinus1RetryOnBlock loc f on_block
+          else if err == eWOULDBLOCK || err == eAGAIN
+                then do on_block
+                 else throwErrno loc
+      else return res
+
+-- -----------------------------------------------------------------------------
 -- wrappers to platform-specific constants:
 
 foreign import ccall unsafe "__hscore_supportsTextMode"