module GHC.IO.Handle.Text (
hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
commitBuffer',
hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
memcpy, hPutStrLn, hGetContents',
) where
import GHC.IO
import GHC.IO.Buffer
import qualified GHC.IO.BufferedIO as Buffered
import GHC.IO.Exception
import GHC.Exception
import GHC.IO.Handle.Types
import GHC.IO.Handle.Internals
import qualified GHC.IO.Device as IODevice
import qualified GHC.IO.Device as RawIO
import Foreign
import Foreign.C
import qualified Control.Exception as Exception
import System.IO.Error
import Data.Either (Either(..))
import Data.Maybe
import GHC.IORef
import GHC.Base
import GHC.Real
import GHC.Num
import GHC.Show
import GHC.List
hWaitForInput :: Handle -> Int -> IO Bool
hWaitForInput h msecs = do
wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
cbuf <- readIORef haCharBuffer
if not (isEmptyBuffer cbuf) then return True else do
if msecs < 0
then do cbuf' <- readTextDevice handle_ cbuf
writeIORef haCharBuffer cbuf'
return True
else do
cbuf' <- decodeByteBuf handle_ cbuf
writeIORef haCharBuffer cbuf'
if not (isEmptyBuffer cbuf') then return True else do
r <- IODevice.ready haDevice False msecs
if r then do
_ <- hLookAhead_ handle_
return True
else return False
hGetChar :: Handle -> IO Char
hGetChar handle =
wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
buf0 <- readIORef haCharBuffer
buf1 <- if isEmptyBuffer buf0
then readTextDevice handle_ buf0
else return buf0
(c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
let buf2 = bufferAdjustL i buf1
if haInputNL == CRLF && c1 == '\r'
then do
mbuf3 <- if isEmptyBuffer buf2
then maybeFillReadBuffer handle_ buf2
else return (Just buf2)
case mbuf3 of
Nothing -> do
writeIORef haCharBuffer buf2
return '\r'
Just buf3 -> do
(c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
if c2 == '\n'
then do
writeIORef haCharBuffer (bufferAdjustL i2 buf3)
return '\n'
else do
writeIORef haCharBuffer buf3
return '\r'
else do
writeIORef haCharBuffer buf2
return c1
hGetLine :: Handle -> IO String
hGetLine h =
wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
hGetLineBuffered handle_
hGetLineBuffered :: Handle__ -> IO String
hGetLineBuffered handle_@Handle__{..} = do
buf <- readIORef haCharBuffer
hGetLineBufferedLoop handle_ buf []
hGetLineBufferedLoop :: Handle__
-> CharBuffer -> [String]
-> IO String
hGetLineBufferedLoop handle_@Handle__{..}
buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
let
loop raw r
| r == w = return (False, w)
| otherwise = do
(c,r') <- readCharBuf raw r
if c == '\n'
then return (True, r)
else loop raw r'
in do
(eol, off) <- loop raw0 r0
debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
(xs,r') <- if haInputNL == CRLF
then unpack_nl raw0 r0 off ""
else do xs <- unpack raw0 r0 off ""
return (xs,off)
if eol
then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
return (concat (reverse (xs:xss)))
else do
let buf1 = bufferAdjustL r' buf
maybe_buf <- maybeFillReadBuffer handle_ buf1
case maybe_buf of
Nothing -> do
let pre = if not (isEmptyBuffer buf1) then "\r" else ""
writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
let str = concat (reverse (pre:xs:xss))
if not (null str)
then return str
else ioe_EOF
Just new_buf ->
hGetLineBufferedLoop handle_ new_buf (xs:xss)
maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
maybeFillReadBuffer handle_ buf
= catchException
(do buf' <- getSomeCharacters handle_ buf
return (Just buf')
)
(\e -> do if isEOFError e
then return Nothing
else ioError e)
#define CHARBUF_UTF32
unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
unpack !buf !r !w acc0
| r == w = return acc0
| otherwise =
withRawBuffer buf $ \pbuf ->
let
unpackRB acc !i
| i < r = return acc
| otherwise = do
#if defined(CHARBUF_UTF16)
c2 <- peekElemOff pbuf i
if (c2 < 0xdc00 || c2 > 0xdffff)
then unpackRB (unsafeChr (fromIntegral c2) : acc) (i1)
else do c1 <- peekElemOff pbuf (i1)
let c = (fromIntegral c1 0xd800) * 0x400 +
(fromIntegral c2 0xdc00) + 0x10000
case desurrogatifyRoundtripCharacter (unsafeChr c) of
{ C# c# -> unpackRB (C# c# : acc) (i2) }
#else
c <- peekElemOff pbuf i
unpackRB (c : acc) (i1)
#endif
in
unpackRB acc0 (w1)
unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
unpack_nl !buf !r !w acc0
| r == w = return (acc0, 0)
| otherwise =
withRawBuffer buf $ \pbuf ->
let
unpackRB acc !i
| i < r = return acc
| otherwise = do
c <- peekElemOff pbuf i
if (c == '\n' && i > r)
then do
c1 <- peekElemOff pbuf (i1)
if (c1 == '\r')
then unpackRB ('\n':acc) (i2)
else unpackRB ('\n':acc) (i1)
else do
unpackRB (c : acc) (i1)
in do
c <- peekElemOff pbuf (w1)
if (c == '\r')
then do
str <- unpackRB acc0 (w2)
return (str, w1)
else do
str <- unpackRB acc0 (w1)
return (str, w)
hGetContents :: Handle -> IO String
hGetContents handle =
wantReadableHandle "hGetContents" handle $ \handle_ -> do
xs <- lazyRead handle
return (handle_{ haType=SemiClosedHandle}, xs )
lazyRead :: Handle -> IO String
lazyRead handle =
unsafeInterleaveIO $
withHandle "hGetContents" handle $ \ handle_ -> do
case haType handle_ of
SemiClosedHandle -> lazyReadBuffered handle handle_
ClosedHandle
-> ioException
(IOError (Just handle) IllegalOperation "hGetContents"
"delayed read on closed handle" Nothing Nothing)
_ -> ioException
(IOError (Just handle) IllegalOperation "hGetContents"
"illegal handle type" Nothing Nothing)
lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
lazyReadBuffered h handle_@Handle__{..} = do
buf <- readIORef haCharBuffer
Exception.catch
(do
buf'@Buffer{..} <- getSomeCharacters handle_ buf
lazy_rest <- lazyRead h
(s,r) <- if haInputNL == CRLF
then unpack_nl bufRaw bufL bufR lazy_rest
else do s <- unpack bufRaw bufL bufR lazy_rest
return (s,bufR)
writeIORef haCharBuffer (bufferAdjustL r buf')
return (handle_, s)
)
(\e -> do (handle_', _) <- hClose_help handle_
debugIO ("hGetContents caught: " ++ show e)
let r = if isEOFError e
then if not (isEmptyBuffer buf)
then "\r"
else ""
else
throw (augmentIOError e "hGetContents" h)
return (handle_', r)
)
getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
case bufferElems buf of
0 -> readTextDevice handle_ buf
1 | haInputNL == CRLF -> do
(c,_) <- readCharBuf bufRaw bufL
if c == '\r'
then do
_ <- writeCharBuf bufRaw 0 '\r'
let buf' = buf{ bufL=0, bufR=1 }
readTextDevice handle_ buf'
else do
return buf
_otherwise ->
return buf
hGetContents' :: Handle -> IO String
hGetContents' handle = do
es <- wantReadableHandle "hGetContents'" handle (strictRead handle)
case es of
Right s -> return s
Left e ->
case fromException e of
Just ioe -> throwIO (augmentIOError ioe "hGetContents'" handle)
Nothing -> throwIO e
strictRead :: Handle -> Handle__ -> IO (Handle__, Either SomeException String)
strictRead h handle_@Handle__{..} = do
cbuf <- readIORef haCharBuffer
cbufs <- strictReadLoop' handle_ [] cbuf
(handle_', me) <- hClose_help handle_
case me of
Just e -> return (handle_', Left e)
Nothing -> do
s <- lazyBuffersToString haInputNL cbufs ""
return (handle_', Right s)
strictReadLoop :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer]
strictReadLoop handle_ cbufs cbuf0 = do
mcbuf <- Exception.catch
(do r <- readTextDevice handle_ cbuf0
return (Just r))
(\e -> if isEOFError e
then return Nothing
else throw e)
case mcbuf of
Nothing -> return (cbuf0 : cbufs)
Just cbuf1 -> strictReadLoop' handle_ cbufs cbuf1
strictReadLoop' :: Handle__ -> [CharBuffer] -> CharBuffer -> IO [CharBuffer]
strictReadLoop' handle_ cbufs cbuf
| isFullCharBuffer cbuf = do
cbuf' <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE ReadBuffer
strictReadLoop handle_ (cbuf : cbufs) cbuf'
| otherwise = strictReadLoop handle_ cbufs cbuf
lazyBuffersToString :: Newline -> [CharBuffer] -> String -> IO String
lazyBuffersToString LF = loop where
loop [] s = return s
loop (Buffer{..} : cbufs) s = do
s' <- unsafeInterleaveIO (unpack bufRaw bufL bufR s)
loop cbufs s'
lazyBuffersToString CRLF = loop '\0' where
loop before [] s = return s
loop before (Buffer{..} : cbufs) s
| bufL == bufR = loop before cbufs s
| otherwise = do
s1 <- if before == '\n'
then return s
else do
c <- peekCharBuf bufRaw (bufR 1)
if c == '\r'
then return ('\r' : s)
else return s
s2 <- unsafeInterleaveIO (do
(s2, _) <- unpack_nl bufRaw bufL bufR s1
return s2)
c0 <- peekCharBuf bufRaw bufL
loop c0 cbufs s2
hPutChar :: Handle -> Char -> IO ()
hPutChar handle c = do
c `seq` return ()
wantWritableHandle "hPutChar" handle $ \ handle_ -> do
hPutcBuffered handle_ c
hPutcBuffered :: Handle__ -> Char -> IO ()
hPutcBuffered handle_@Handle__{..} c = do
buf <- readIORef haCharBuffer
if c == '\n'
then do buf1 <- if haOutputNL == CRLF
then do
buf1 <- putc buf '\r'
putc buf1 '\n'
else do
putc buf '\n'
writeCharBuffer handle_ buf1
when is_line $ flushByteWriteBuffer handle_
else do
buf1 <- putc buf c
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'
return buf{ bufR = w' }
hPutStr :: Handle -> String -> IO ()
hPutStr handle str = hPutStr' handle str False
hPutStrLn :: Handle -> String -> IO ()
hPutStrLn handle str = hPutStr' handle str True
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_)
case buffer_mode of
(NoBuffering, _) -> do
hPutChars handle str
when add_nl $ hPutChar handle '\n'
(LineBuffering, buf) -> do
writeBlocks handle True add_nl nl buf str
(BlockBuffering _, buf) -> do
writeBlocks handle False add_nl nl buf str
hPutChars :: Handle -> [Char] -> IO ()
hPutChars _ [] = return ()
hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
getSpareBuffer Handle__{haCharBuffer=ref,
haBuffers=spare_ref,
haBufferMode=mode}
= do
case mode of
NoBuffering -> return (mode, errorWithoutStackTrace "no buffer!")
_ -> do
bufs <- readIORef spare_ref
buf <- readIORef ref
case bufs of
BufferListCons b rest -> do
writeIORef spare_ref rest
return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
BufferListNil -> do
new_buf <- newCharBuffer (bufSize buf) WriteBuffer
return (mode, new_buf)
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] -> [Char] -> IO ()
shoveString !n [] [] = do
commitBuffer hdl raw len n False True
shoveString !n [] rest = do
shoveString n rest []
shoveString !n (c:cs) rest
| n + 1 >= len = do
commitBuffer hdl raw len n False False
shoveString 0 (c:cs) rest
| c == '\n' = do
n' <- if nl == CRLF
then do
n1 <- writeCharBuf raw n '\r'
writeCharBuf raw n1 '\n'
else do
writeCharBuf raw n c
if line_buffered
then do
commitBuffer hdl raw len n' True False
shoveString 0 cs rest
else do
shoveString n' cs rest
| otherwise = do
n' <- writeCharBuf raw n c
shoveString n' cs rest
in
shoveString 0 s (if add_nl then "\n" else "")
commitBuffer
:: Handle
-> RawCharBuffer -> Int
-> Int
-> Bool
-> Bool
-> IO ()
commitBuffer hdl !raw !sz !count flush release =
wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
++ ", flush=" ++ show flush ++ ", release=" ++ show release ++ ", handle=" ++ show hdl)
writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer, bufOffset=0,
bufL=0, bufR=count, bufSize=sz }
when flush $ flushByteWriteBuffer h_
when release $ do
old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
when (sz == size) $ do
spare_bufs <- readIORef haBuffers
writeIORef haBuffers (BufferListCons raw spare_bufs)
return ()
commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
-> IO CharBuffer
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)
let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,
bufL=0, bufR=count, bufSize=sz, bufOffset=0 }
writeCharBuffer h_ this_buf
when flush $ flushByteWriteBuffer h_
when release $ do
old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
when (sz == size) $ do
spare_bufs <- readIORef haBuffers
writeIORef haBuffers (BufferListCons raw spare_bufs)
return this_buf
hPutBuf :: Handle
-> Ptr a
-> Int
-> IO ()
hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
return ()
hPutBufNonBlocking
:: Handle
-> Ptr a
-> Int
-> IO Int
hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
hPutBuf':: Handle
-> Ptr a
-> Int
-> Bool
-> IO Int
hPutBuf' handle ptr count can_block
| count == 0 = return 0
| count < 0 = illegalBufferSize handle "hPutBuf" count
| otherwise =
wantWritableHandle "hPutBuf" handle $
\ h_@Handle__{..} -> do
debugIO ("hPutBuf count=" ++ show count)
r <- bufWrite h_ (castPtr ptr) count can_block
case haBufferMode of
BlockBuffering _ -> do return ()
_line_or_no_buffering -> do flushWriteBuffer h_
return r
bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
bufWrite h_@Handle__{..} ptr !count can_block = do
old_buf@Buffer{ bufR=w, bufSize=size }
<- readIORef haByteBuffer
b <- if (count < size && count <= size w)
then bufferChunk h_ old_buf ptr count
else do
flushed_buf <- flushByteWriteBufferGiven h_ old_buf
if count < size
then bufferChunk h_ flushed_buf ptr count
else do
let offset = bufOffset flushed_buf
!bytes <- if can_block
then do writeChunk h_ (castPtr ptr) offset count
else writeChunkNonBlocking h_ (castPtr ptr) offset count
writeIORef haByteBuffer $! bufferAddOffset bytes flushed_buf
return bytes
debugIO "hPutBuf: done"
return b
flushByteWriteBufferGiven :: Handle__ -> Buffer Word8 -> IO (Buffer Word8)
flushByteWriteBufferGiven h_@Handle__{..} bbuf = do
if (not (isEmptyBuffer bbuf))
then do
bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
debugIO ("flushByteWriteBufferGiven: bbuf=" ++ summaryBuffer bbuf')
writeIORef haByteBuffer bbuf'
return bbuf'
else
return bbuf
bufferChunk :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> IO Int
bufferChunk h_@Handle__{..} old_buf@Buffer{ bufRaw=raw, bufR=w, bufSize=size } ptr !count = do
debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
copyToRawBuffer raw w ptr count
let copied_buf = old_buf{ bufR = w + count }
if isFullBuffer copied_buf
then do
debugIO "hPutBuf: flushing full buffer after writing"
_ <- flushByteWriteBufferGiven h_ copied_buf
return ()
else do
writeIORef haByteBuffer copied_buf
return count
writeChunk :: Handle__ -> Ptr Word8 -> Word64 -> Int -> IO Int
writeChunk h_@Handle__{..} ptr offset bytes
= do RawIO.write haDevice ptr offset bytes
return bytes
writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Word64 -> Int -> IO Int
writeChunkNonBlocking h_@Handle__{..} ptr offset bytes
= RawIO.writeNonBlocking haDevice ptr offset bytes
hGetBuf :: Handle -> Ptr a -> Int -> IO Int
hGetBuf h !ptr count
| count == 0 = return 0
| count < 0 = illegalBufferSize h "hGetBuf" count
| otherwise =
wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
debugIO $ ":: hGetBuf - " ++ show h ++ " - " ++ show count
flushCharReadBuffer h_
buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
<- readIORef haByteBuffer
debugIO ("hGetBuf: " ++ summaryBuffer buf)
res <- if isEmptyBuffer buf
then bufReadEmpty h_ buf (castPtr ptr) 0 count
else bufReadNonEmpty h_ buf (castPtr ptr) 0 count
debugIO "** hGetBuf done."
return res
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
debugIO ":: bufReadNonEmpty"
let avail = w r
if (count < avail)
then do
copyFromRawBuffer ptr raw r count
writeIORef haByteBuffer buf{ bufL = r + count }
return (so_far + count)
else do
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
debugIO ("bufReadNonEmpty: " ++ summaryBuffer buf' ++ " s:" ++ show so_far' ++ " r:" ++ show remaining)
b <- if remaining == 0
then return so_far'
else bufReadEmpty h_ buf' ptr' so_far' remaining
debugIO ":: bufReadNonEmpty - done"
return b
bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
bufReadEmpty h_@Handle__{..}
buf@Buffer{ bufRaw=raw, bufR=w, bufL=_r, bufSize=sz, bufOffset=bff }
ptr so_far count
| count > sz
= do
bytes_read <- loop haDevice 0 bff count
let buf1 = bufferAddOffset (fromIntegral $ bytes_read so_far) buf
writeIORef haByteBuffer buf1
debugIO ("bufReadEmpty1.1: " ++ summaryBuffer buf1 ++ " read:" ++ show bytes_read)
return bytes_read
| otherwise = do
(r,buf') <- Buffered.fillReadBuffer haDevice buf
writeIORef haByteBuffer buf'
if r == 0
then return so_far
else bufReadNonEmpty h_ buf' ptr so_far count
where
loop :: RawIO.RawIO dev => dev -> Int -> Word64 -> Int -> IO Int
loop dev delta off bytes | bytes <= 0 = return (so_far + delta)
loop dev delta off bytes = do
r <- RawIO.read dev (ptr `plusPtr` delta) off bytes
debugIO $ show ptr ++ " - loop read@" ++ show delta ++ ": " ++ show r
debugIO $ "next:" ++ show (delta + r) ++ " - left:" ++ show (bytes r)
if r == 0
then return (so_far + delta)
else loop dev (delta + r) (off + fromIntegral r) (bytes r)
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 case count > sz of
True -> RawIO.read haDevice (castPtr ptr) 0 count
_ -> 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)
else
let count' = min count (bufferElems buf)
in bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count'
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_@Handle__{..} -> do
flushCharReadBuffer h_
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
, bufOffset=offset }
ptr so_far count
| count > sz = do
m <- RawIO.readNonBlocking haDevice ptr offset count
case m of
Nothing -> return so_far
Just n -> return (so_far + n)
| otherwise = 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'
bufReadNBNonEmpty h_ buf' ptr so_far (min count r')
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{ bufL = r + count }
return (so_far + count)
else do
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 == 0
then return so_far'
else bufReadNBEmpty h_ buf' ptr' so_far' remaining
copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
copyToRawBuffer raw off ptr bytes =
withRawBuffer raw $ \praw ->
do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
return ()
copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
copyFromRawBuffer ptr raw off bytes =
withRawBuffer raw $ \praw ->
do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
return ()
foreign import ccall unsafe "memcpy"
memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
illegalBufferSize :: Handle -> String -> Int -> IO a
illegalBufferSize handle fn sz =
ioException (IOError (Just handle)
InvalidArgument fn
("illegal buffer size " ++ showsPrec 9 sz [])
Nothing Nothing)