X-Git-Url: http://git.megacz.com/?p=ghc-base.git;a=blobdiff_plain;f=GHC%2FIO%2FHandle%2FText.hs;h=0d0e05b4d5fc93119730580e0f434ba9b1db505e;hp=ebbacd43348569941f66cba9b24d9d333eb19633;hb=HEAD;hpb=d9b146b931c749029a914cd70a2ff109b83784dc diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs index ebbacd4..0d0e05b 100644 --- a/GHC/IO/Handle/Text.hs +++ b/GHC/IO/Handle/Text.hs @@ -1,5 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} -{-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , RecordWildCards + , BangPatterns + , PatternGuards + , NondecreasingIndentation + , MagicHash + , ForeignFunctionInterface + #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_HADDOCK hide #-} @@ -22,8 +29,8 @@ module GHC.IO.Handle.Text ( hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, commitBuffer', -- hack, see below - hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, - memcpy, + hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, + memcpy, hPutStrLn, ) where import GHC.IO @@ -31,6 +38,8 @@ import GHC.IO.FD import GHC.IO.Buffer import qualified GHC.IO.BufferedIO as Buffered import GHC.IO.Exception +import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter) +import GHC.Exception import GHC.IO.Handle.Types import GHC.IO.Handle.Internals import qualified GHC.IO.Device as IODevice @@ -39,6 +48,7 @@ import qualified GHC.IO.Device as RawIO import Foreign import Foreign.C +import qualified Control.Exception as Exception import Data.Typeable import System.IO.Error import Data.Maybe @@ -62,7 +72,10 @@ import GHC.List -- | Computation 'hWaitForInput' @hdl t@ -- waits until input is available on handle @hdl@. -- It returns 'True' as soon as input is available on @hdl@, --- or 'False' if no input is available within @t@ milliseconds. +-- or 'False' if no input is available within @t@ milliseconds. Note that +-- 'hWaitForInput' waits until one or more full /characters/ are available, +-- which means that it needs to do decoding, and hence may fail +-- with a decoding error. -- -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. -- @@ -70,10 +83,14 @@ import GHC.List -- -- * 'isEOFError' if the end of file has been reached. -- +-- * a decoding error, if the input begins with an invalid byte sequence +-- in this Handle's encoding. +-- -- NOTE for GHC users: unless you use the @-threaded@ flag, -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell -- threads for the duration of the call. It behaves like a -- @safe@ foreign call in this respect. +-- hWaitForInput :: Handle -> Int -> IO Bool hWaitForInput h msecs = do @@ -88,7 +105,7 @@ hWaitForInput h msecs = do return True else do -- there might be bytes in the byte buffer waiting to be decoded - cbuf' <- readTextDeviceNonBlocking handle_ cbuf + cbuf' <- decodeByteBuf handle_ cbuf writeIORef haCharBuffer cbuf' if not (isEmptyBuffer cbuf') then return True else do @@ -160,9 +177,6 @@ hGetChar handle = -- --------------------------------------------------------------------------- -- hGetLine --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. - -- | Computation 'hGetLine' @hdl@ reads a line from the file or -- channel managed by @hdl@. -- @@ -236,12 +250,12 @@ hGetLineBufferedLoop handle_@Handle__{..} maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catch + = Exception.catch (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e - then return Nothing + (\e -> do if isEOFError e + then return Nothing else ioError e) -- See GHC.IO.Buffer @@ -266,10 +280,10 @@ unpack !buf !r !w acc0 else do c1 <- peekElemOff pbuf (i-1) let c = (fromIntegral c1 - 0xd800) * 0x400 + (fromIntegral c2 - 0xdc00) + 0x10000 - unpackRB (unsafeChr c : acc) (i-2) + unpackRB (desurrogatifyRoundtripCharacter (unsafeChr c) : acc) (i-2) #else c <- peekElemOff pbuf i - unpackRB (c:acc) (i-1) + unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1) #endif in unpackRB acc0 (w-1) @@ -292,7 +306,7 @@ unpack_nl !buf !r !w acc0 then unpackRB ('\n':acc) (i-2) else unpackRB ('\n':acc) (i-1) else do - unpackRB (c:acc) (i-1) + unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1) in do c <- peekElemOff pbuf (w-1) if (c == '\r') @@ -366,8 +380,8 @@ lazyRead handle = lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - catch - (do + Exception.catch + (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h (s,r) <- if haInputNL == CRLF @@ -381,11 +395,14 @@ lazyReadBuffered h handle_@Handle__{..} = do debugIO ("hGetContents caught: " ++ show e) -- We might have a \r cached in CRLF mode. So we -- need to check for that and return it: - if isEOFError e - then if not (isEmptyBuffer buf) - then return (handle_', "\r") - else return (handle_', "") - else ioError e + let r = if isEOFError e + then if not (isEmptyBuffer buf) + then "\r" + else "" + else + throw (augmentIOError e "hGetContents" h) + + return (handle_', r) ) -- ensure we have some characters in the buffer @@ -432,12 +449,10 @@ hPutChar :: Handle -> Char -> IO () hPutChar handle c = do c `seq` return () wantWritableHandle "hPutChar" handle $ \ handle_ -> do - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - _other -> hPutcBuffered handle_ False c + hPutcBuffered handle_ c -hPutcBuffered :: Handle__ -> Bool -> Char -> IO () -hPutcBuffered handle_@Handle__{..} is_line c = do +hPutcBuffered :: Handle__ -> Char -> IO () +hPutcBuffered handle_@Handle__{..} c = do buf <- readIORef haCharBuffer if c == '\n' then do buf1 <- if haOutputNL == CRLF @@ -446,23 +461,21 @@ hPutcBuffered handle_@Handle__{..} is_line c = do putc buf1 '\n' else do putc buf '\n' - if is_line - then do - flushed_buf <- flushWriteBuffer_ handle_ buf1 - writeIORef haCharBuffer flushed_buf - else - writeIORef haCharBuffer buf1 + writeCharBuffer handle_ buf1 + when is_line $ flushByteWriteBuffer handle_ else do buf1 <- putc buf c - writeIORef haCharBuffer buf1 + writeCharBuffer handle_ buf1 + return () where + is_line = case haBufferMode of + LineBuffering -> True + _ -> False + putc buf@Buffer{ bufRaw=raw, bufR=w } c = do debugIO ("putc: " ++ summaryBuffer buf) w' <- writeCharBuf raw w c - let buf' = buf{ bufR = w' } - if isFullCharBuffer buf' - then flushWriteBuffer_ handle_ buf' - else return buf' + return buf{ bufR = w' } -- --------------------------------------------------------------------------- -- hPutStr @@ -494,8 +507,19 @@ hPutcBuffered handle_@Handle__{..} is_line c = do -- * 'isPermissionError' if another system resource limit would be exceeded. hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - (buffer_mode, nl) <- +hPutStr handle str = hPutStr' handle str False + +-- | The same as 'hPutStr', but adds a newline character. +hPutStrLn :: Handle -> String -> IO () +hPutStrLn handle str = hPutStr' handle str True + -- An optimisation: we treat hPutStrLn specially, to avoid the + -- overhead of a single putChar '\n', which is quite high now that we + -- have to encode eagerly. + +hPutStr' :: Handle -> String -> Bool -> IO () +hPutStr' handle str add_nl = + do + (buffer_mode, nl) <- wantWritableHandle "hPutStr" handle $ \h_ -> do bmode <- getSpareBuffer h_ return (bmode, haOutputNL h_) @@ -503,10 +527,11 @@ hPutStr handle str = do case buffer_mode of (NoBuffering, _) -> do hPutChars handle str -- v. slow, but we don't care + when add_nl $ hPutChar handle '\n' (LineBuffering, buf) -> do - writeBlocks handle True nl buf str + writeBlocks handle True add_nl nl buf str (BlockBuffering _, buf) -> do - writeBlocks handle False nl buf str + writeBlocks handle False add_nl nl buf str hPutChars :: Handle -> [Char] -> IO () hPutChars _ [] = return () @@ -532,19 +557,20 @@ getSpareBuffer Handle__{haCharBuffer=ref, -- NB. performance-critical code: eyeball the Core. -writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO () -writeBlocks hdl line_buffered nl +writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO () +writeBlocks hdl line_buffered add_nl nl buf@Buffer{ bufRaw=raw, bufSize=len } s = let - shoveString :: Int -> [Char] -> IO () - shoveString !n [] = do - _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString !n (c:cs) + shoveString :: Int -> [Char] -> [Char] -> IO () + shoveString !n [] [] = do + commitBuffer hdl raw len n False{-no flush-} True{-release-} + shoveString !n [] rest = do + shoveString n rest [] + shoveString !n (c:cs) rest -- n+1 so we have enough room to write '\r\n' if necessary | n + 1 >= len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeBlocks hdl line_buffered nl new_buf (c:cs) + commitBuffer hdl raw len n False{-flush-} False + shoveString 0 (c:cs) rest | c == '\n' = do n' <- if nl == CRLF then do @@ -554,36 +580,22 @@ writeBlocks hdl line_buffered nl writeCharBuf raw n c if line_buffered then do - new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False - writeBlocks hdl line_buffered nl new_buf cs + -- end of line, so write and flush + commitBuffer hdl raw len n' True{-flush-} False + shoveString 0 cs rest else do - shoveString n' cs + shoveString n' cs rest | otherwise = do - n' <- writeCharBuf raw n c - shoveString n' cs + n' <- writeCharBuf raw n (surrogatifyRoundtripCharacter c) + shoveString n' cs rest in - shoveString 0 s + shoveString 0 s (if add_nl then "\n" else "") -- ----------------------------------------------------------------------------- -- commitBuffer handle buf sz count flush release -- -- Write the contents of the buffer 'buf' ('sz' bytes long, containing -- 'count' bytes of data) to handle (handle must be block or line buffered). --- --- Implementation: --- --- for block/line buffering, --- 1. If there isn't room in the handle buffer, flush the handle --- buffer. --- --- 2. If the handle buffer is empty, --- if flush, --- then write buf directly to the device. --- else swap the handle buffer with buf. --- --- 3. If the handle buffer is non-empty, copy buf into the --- handle buffer. Then, if flush != 0, flush --- the buffer. commitBuffer :: Handle -- handle to commit to @@ -591,93 +603,52 @@ commitBuffer -> Int -- number of bytes of data in buffer -> Bool -- True <=> flush the handle afterward -> Bool -- release the buffer? - -> IO CharBuffer + -> IO () commitBuffer hdl !raw !sz !count flush release = - wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' raw sz count flush release -{-# NOINLINE commitBuffer #-} + wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do + debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count + ++ ", flush=" ++ show flush ++ ", release=" ++ show release) --- Explicitly lambda-lift this function to subvert GHC's full laziness --- optimisations, which otherwise tends to float out subexpressions --- past the \handle, which is really a pessimisation in this case because --- that lambda is a one-shot lambda. --- --- Don't forget to export the function, to stop it being inlined too --- (this appears to be better than NOINLINE, because the strictness --- analyser still gets to worker-wrapper it). --- --- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 --- + writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer, + bufL=0, bufR=count, bufSize=sz } + + when flush $ flushByteWriteBuffer h_ + + -- release the buffer if necessary + when release $ do + -- find size of current buffer + old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer + when (sz == size) $ do + spare_bufs <- readIORef haBuffers + writeIORef haBuffers (BufferListCons raw spare_bufs) + + return () + +-- backwards compatibility; the text package uses this commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__ -> IO CharBuffer -commitBuffer' raw sz@(I# _) count@(I# _) flush release - handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do - +commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..} + = do debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count ++ ", flush=" ++ show flush ++ ", release=" ++ show release) - old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size } - <- readIORef ref - - buf_ret <- - -- enough room in handle buffer? - if (not flush && (size - w > count)) - -- The > is to be sure that we never exactly fill - -- up the buffer, which would require a flush. So - -- if copying the new data into the buffer would - -- make the buffer full, we just flush the existing - -- buffer and the new data immediately, rather than - -- copying before flushing. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufR. - then do withRawBuffer raw $ \praw -> - copyToRawBuffer old_raw (w*charSize) - praw (fromIntegral (count*charSize)) - writeIORef ref old_buf{ bufR = w + count } - return (emptyBuffer raw sz WriteBuffer) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer_ handle_ old_buf - - let this_buf = - Buffer{ bufRaw=raw, bufState=WriteBuffer, - bufL=0, bufR=count, bufSize=sz } - - -- if: (a) we don't have to flush, and - -- (b) size(new buffer) == size(old buffer), and - -- (c) new buffer is not full, - -- we can just just swap them over... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - -- We're aren't going to use this buffer again - -- so we ignore the result of flushWriteBuffer_ - _ <- flushWriteBuffer_ handle_ this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (emptyBuffer raw sz WriteBuffer) - else newCharBuffer size WriteBuffer + let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer, + bufL=0, bufR=count, bufSize=sz } + + writeCharBuffer h_ this_buf + + when flush $ flushByteWriteBuffer h_ -- release the buffer if necessary - case buf_ret of - Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do - if release && buf_ret_sz == size - then do - spare_bufs <- readIORef spare_buf_ref - writeIORef spare_buf_ref - (BufferListCons buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret + when release $ do + -- find size of current buffer + old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer + when (sz == size) $ do + spare_bufs <- readIORef haBuffers + writeIORef haBuffers (BufferListCons raw spare_bufs) + + return this_buf -- --------------------------------------------------------------------------- -- Reading/writing sequences of bytes. @@ -727,10 +698,6 @@ hPutBuf' handle ptr count can_block wantWritableHandle "hPutBuf" handle $ \ h_@Handle__{..} -> do debugIO ("hPutBuf count=" ++ show count) - -- first flush the Char buffer if it is non-empty, then we - -- can work directly with the byte buffer - cbuf <- readIORef haCharBuffer - when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_ r <- bufWrite h_ (castPtr ptr) count can_block @@ -753,7 +720,7 @@ bufWrite h_@Handle__{..} ptr count can_block = -- There's enough room in the buffer: -- just copy the data in and update bufR. then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w) - copyToRawBuffer old_raw w ptr (fromIntegral count) + copyToRawBuffer old_raw w ptr count writeIORef haByteBuffer old_buf{ bufR = w + count } return count @@ -789,9 +756,6 @@ writeChunkNonBlocking h_@Handle__{..} ptr bytes -- It returns the number of bytes actually read. This may be zero if -- EOF was reached before any data was read (or if @count@ is zero). -- --- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently --- using, and reads bytes directly from the underlying IO device. --- -- 'hGetBuf' never raises an EOF exception, instead it returns a value -- smaller than @count@. -- @@ -806,34 +770,24 @@ hGetBuf h ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBuf" count | otherwise = - wantReadableHandle_ "hGetBuf" h $ \ h_ -> do + wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do flushCharReadBuffer h_ - bufRead h_ (castPtr ptr) 0 count + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + <- readIORef haByteBuffer + if isEmptyBuffer buf + then bufReadEmpty h_ buf (castPtr ptr) 0 count + else bufReadNonEmpty h_ buf (castPtr ptr) 0 count -- small reads go through the buffer, large reads are satisfied by -- taking data first from the buffer and then direct from the file -- descriptor. -bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int -bufRead h_@Handle__{..} ptr so_far count = - seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer - if isEmptyBuffer buf - then if count > sz -- small read? - then do rest <- readChunk h_ ptr count - return (so_far + rest) - else do (r,buf') <- Buffered.fillReadBuffer haDevice buf - if r == 0 - then return so_far - else do writeIORef haByteBuffer buf' - bufRead h_ ptr so_far count - else do + +bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNonEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr !so_far !count + = do let avail = w - r - if (count == avail) - then do - copyFromRawBuffer ptr raw r count - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } - return (so_far + count) - else do if (count < avail) then do copyFromRawBuffer ptr raw r count @@ -841,32 +795,86 @@ bufRead h_@Handle__{..} ptr so_far count = return (so_far + count) else do - copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + copyFromRawBuffer ptr raw r avail + let buf' = buf{ bufR=0, bufL=0 } + writeIORef haByteBuffer buf' let remaining = count - avail so_far' = so_far + avail ptr' = ptr `plusPtr` avail - if remaining < sz - then bufRead h_ ptr' so_far' remaining - else do - - rest <- readChunk h_ ptr' remaining - return (so_far' + rest) - -readChunk :: Handle__ -> Ptr a -> Int -> IO Int -readChunk h_@Handle__{..} ptr bytes - | Just fd <- cast haDevice = loop fd 0 bytes - | otherwise = error "ToDo: hGetBuf" + if remaining == 0 + then return so_far' + else bufReadEmpty h_ buf' ptr' so_far' remaining + + +bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + | count > sz, Just fd <- cast haDevice = loop fd 0 count + | otherwise = do + (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return so_far + else do writeIORef haByteBuffer buf' + bufReadNonEmpty h_ buf' ptr so_far count where loop :: FD -> Int -> Int -> IO Int - loop fd off bytes | bytes <= 0 = return off + loop fd off bytes | bytes <= 0 = return (so_far + off) loop fd off bytes = do - r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes) + r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes if r == 0 - then return off + then return (so_far + off) else loop fd (off + r) (bytes - r) +-- --------------------------------------------------------------------------- +-- hGetBufSome + +-- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@ +-- into the buffer @buf@. If there is any data available to read, +-- then 'hGetBufSome' returns it immediately; it only blocks if there +-- is no data to be read. +-- +-- It returns the number of bytes actually read. This may be zero if +-- EOF was reached before any data was read (or if @count@ is zero). +-- +-- 'hGetBufSome' never raises an EOF exception, instead it returns a value +-- smaller than @count@. +-- +-- If the handle is a pipe or socket, and the writing end +-- is closed, 'hGetBufSome' will behave as if EOF was reached. +-- +-- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode' +-- on the 'Handle', and reads bytes directly. + +hGetBufSome :: Handle -> Ptr a -> Int -> IO Int +hGetBufSome h ptr count + | count == 0 = return 0 + | count < 0 = illegalBufferSize h "hGetBufSome" count + | otherwise = + wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do + flushCharReadBuffer h_ + buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer + if isEmptyBuffer buf + then if count > sz -- large read? + then do RawIO.read (haFD h_) (castPtr ptr) count + else do (r,buf') <- Buffered.fillReadBuffer haDevice buf + if r == 0 + then return 0 + else do writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count) + -- new count is (min r count), so + -- that bufReadNBNonEmpty will not + -- issue another read. + else + bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count + +haFD :: Handle__ -> FD +haFD h_@Handle__{..} = + case cast haDevice of + Nothing -> error "not an FD" + Just fd -> fd + -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@ -- into the buffer @buf@ until either EOF is reached, or -- @count@ 8-bit bytes have been read, or there is no more data available @@ -877,52 +885,60 @@ readChunk h_@Handle__{..} ptr bytes -- only whatever data is available. To wait for data to arrive before -- calling 'hGetBufNonBlocking', use 'hWaitForInput'. -- --- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle' --- is currently using, and reads bytes directly from the underlying IO --- device. --- -- If the handle is a pipe or socket, and the writing end -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. -- -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and -- 'NewlineMode' on the 'Handle', and reads bytes directly. +-- +-- NOTE: on Windows, this function does not work correctly; it +-- behaves identically to 'hGetBuf'. hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int hGetBufNonBlocking h ptr count | count == 0 = return 0 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count | otherwise = - wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do + wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do flushCharReadBuffer h_ - bufReadNonBlocking h_ (castPtr ptr) 0 count - -bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int -bufReadNonBlocking h_@Handle__{..} ptr so_far count = - seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer - if isEmptyBuffer buf - then if count > sz -- large read? - then do rest <- readChunkNonBlocking h_ ptr count - return (so_far + rest) - else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf - case r of - Nothing -> return so_far - Just 0 -> return so_far - Just r -> do - writeIORef haByteBuffer buf' - bufReadNonBlocking h_ ptr so_far (min count r) - -- NOTE: new count is min count w' - -- so we will just copy the contents of the - -- buffer in the recursive call, and not - -- loop again. - else do + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + <- readIORef haByteBuffer + if isEmptyBuffer buf + then bufReadNBEmpty h_ buf (castPtr ptr) 0 count + else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count + +bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNBEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + | count > sz, + Just fd <- cast haDevice = do + m <- RawIO.readNonBlocking (fd::FD) ptr count + case m of + Nothing -> return so_far + Just n -> return (so_far + n) + + | otherwise = do + buf <- readIORef haByteBuffer + (r,buf') <- Buffered.fillReadBuffer0 haDevice buf + case r of + Nothing -> return so_far + Just 0 -> return so_far + Just r -> do + writeIORef haByteBuffer buf' + bufReadNBNonEmpty h_ buf' ptr so_far (min count r) + -- NOTE: new count is min count r + -- so we will just copy the contents of the + -- buffer in the recursive call, and not + -- loop again. + + +bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int +bufReadNBNonEmpty h_@Handle__{..} + buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } + ptr so_far count + = do let avail = w - r - if (count == avail) - then do - copyFromRawBuffer ptr raw r count - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } - return (so_far + count) - else do if (count < avail) then do copyFromRawBuffer ptr raw r count @@ -930,29 +946,16 @@ bufReadNonBlocking h_@Handle__{..} ptr so_far count = return (so_far + count) else do - copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef haByteBuffer buf{ bufR=0, bufL=0 } + copyFromRawBuffer ptr raw r avail + let buf' = buf{ bufR=0, bufL=0 } + writeIORef haByteBuffer buf' let remaining = count - avail so_far' = so_far + avail ptr' = ptr `plusPtr` avail - -- we haven't attempted to read anything yet if we get to here. - if remaining < sz - then bufReadNonBlocking h_ ptr' so_far' remaining - else do - - rest <- readChunkNonBlocking h_ ptr' remaining - return (so_far' + rest) - - -readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int -readChunkNonBlocking h_@Handle__{..} ptr bytes - | Just fd <- cast haDevice = do - m <- RawIO.readNonBlocking (fd::FD) ptr bytes - case m of - Nothing -> return 0 - Just n -> return n - | otherwise = error "ToDo: hGetBuf" + if remaining == 0 + then return so_far' + else bufReadNBEmpty h_ buf' ptr' so_far' remaining -- --------------------------------------------------------------------------- -- memcpy wrappers