1 {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
2 {-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-}
3 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
4 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
5 {-# OPTIONS_HADDOCK hide #-}
7 -----------------------------------------------------------------------------
9 -- Module : GHC.IO.Text
10 -- Copyright : (c) The University of Glasgow, 1992-2008
11 -- License : see libraries/base/LICENSE
13 -- Maintainer : libraries@haskell.org
14 -- Stability : internal
15 -- Portability : non-portable
17 -- String I\/O functions
19 -----------------------------------------------------------------------------
22 module GHC.IO.Handle.Text (
23 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
24 commitBuffer', -- hack, see below
25 hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
32 import qualified GHC.IO.BufferedIO as Buffered
33 import GHC.IO.Exception
35 import GHC.IO.Handle.Types
36 import GHC.IO.Handle.Internals
37 import qualified GHC.IO.Device as IODevice
38 import qualified GHC.IO.Device as RawIO
44 import System.IO.Error
55 -- ---------------------------------------------------------------------------
56 -- Simple input operations
58 -- If hWaitForInput finds anything in the Handle's buffer, it
59 -- immediately returns. If not, it tries to read from the underlying
60 -- OS handle. Notice that for buffered Handles connected to terminals
61 -- this means waiting until a complete line is available.
63 -- | Computation 'hWaitForInput' @hdl t@
64 -- waits until input is available on handle @hdl@.
65 -- It returns 'True' as soon as input is available on @hdl@,
66 -- or 'False' if no input is available within @t@ milliseconds. Note that
67 -- 'hWaitForInput' waits until one or more full /characters/ are available,
68 -- which means that it needs to do decoding, and hence may fail
69 -- with a decoding error.
71 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
73 -- This operation may fail with:
75 -- * 'isEOFError' if the end of file has been reached.
76 -- * a decoding error, if the input begins with an invalid byte sequence
77 -- in this Handle's encoding.
79 -- NOTE for GHC users: unless you use the @-threaded@ flag,
80 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
81 -- threads for the duration of the call. It behaves like a
82 -- @safe@ foreign call in this respect.
85 hWaitForInput :: Handle -> Int -> IO Bool
86 hWaitForInput h msecs = do
87 wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
88 cbuf <- readIORef haCharBuffer
90 if not (isEmptyBuffer cbuf) then return True else do
93 then do cbuf' <- readTextDevice handle_ cbuf
94 writeIORef haCharBuffer cbuf'
97 -- there might be bytes in the byte buffer waiting to be decoded
98 cbuf' <- decodeByteBuf handle_ cbuf
99 writeIORef haCharBuffer cbuf'
101 if not (isEmptyBuffer cbuf') then return True else do
103 r <- IODevice.ready haDevice False{-read-} msecs
104 if r then do -- Call hLookAhead' to throw an EOF
105 -- exception if appropriate
106 _ <- hLookAhead_ handle_
109 -- XXX we should only return when there are full characters
110 -- not when there are only bytes. That would mean looping
111 -- and re-running IODevice.ready if we don't have any full
112 -- characters; but we don't know how long we've waited
115 -- ---------------------------------------------------------------------------
118 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
119 -- channel managed by @hdl@, blocking until a character is available.
121 -- This operation may fail with:
123 -- * 'isEOFError' if the end of file has been reached.
125 hGetChar :: Handle -> IO Char
127 wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
129 -- buffering mode makes no difference: we just read whatever is available
130 -- from the device (blocking only if there is nothing available), and then
131 -- return the first character.
132 -- See [note Buffered Reading] in GHC.IO.Handle.Types
133 buf0 <- readIORef haCharBuffer
135 buf1 <- if isEmptyBuffer buf0
136 then readTextDevice handle_ buf0
139 (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
140 let buf2 = bufferAdjustL i buf1
142 if haInputNL == CRLF && c1 == '\r'
144 mbuf3 <- if isEmptyBuffer buf2
145 then maybeFillReadBuffer handle_ buf2
146 else return (Just buf2)
149 -- EOF, so just return the '\r' we have
151 writeIORef haCharBuffer buf2
154 (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
157 writeIORef haCharBuffer (bufferAdjustL i2 buf3)
160 -- not a \r\n sequence, so just return the \r
161 writeIORef haCharBuffer buf3
164 writeIORef haCharBuffer buf2
167 -- ---------------------------------------------------------------------------
170 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
171 -- channel managed by @hdl@.
173 -- This operation may fail with:
175 -- * 'isEOFError' if the end of file is encountered when reading
176 -- the /first/ character of the line.
178 -- If 'hGetLine' encounters end-of-file at any other point while reading
179 -- in a line, it is treated as a line terminator and the (partial)
182 hGetLine :: Handle -> IO String
184 wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
185 hGetLineBuffered handle_
187 hGetLineBuffered :: Handle__ -> IO String
188 hGetLineBuffered handle_@Handle__{..} = do
189 buf <- readIORef haCharBuffer
190 hGetLineBufferedLoop handle_ buf []
192 hGetLineBufferedLoop :: Handle__
193 -> CharBuffer -> [String]
195 hGetLineBufferedLoop handle_@Handle__{..}
196 buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
198 -- find the end-of-line character, if there is one
200 | r == w = return (False, w)
202 (c,r') <- readCharBuf raw r
204 then return (True, r) -- NB. not r': don't include the '\n'
207 (eol, off) <- loop raw0 r0
209 debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
211 (xs,r') <- if haInputNL == CRLF
212 then unpack_nl raw0 r0 off ""
213 else do xs <- unpack raw0 r0 off ""
216 -- if eol == True, then off is the offset of the '\n'
217 -- otherwise off == w and the buffer is now empty.
219 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
220 return (concat (reverse (xs:xss)))
222 let buf1 = bufferAdjustL r' buf
223 maybe_buf <- maybeFillReadBuffer handle_ buf1
225 -- Nothing indicates we caught an EOF, and we may have a
226 -- partial line to return.
228 -- we reached EOF. There might be a lone \r left
229 -- in the buffer, so check for that and
230 -- append it to the line if necessary.
232 let pre = if not (isEmptyBuffer buf1) then "\r" else ""
233 writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
234 let str = concat (reverse (pre:xs:xss))
239 hGetLineBufferedLoop handle_ new_buf (xs:xss)
241 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
242 maybeFillReadBuffer handle_ buf
244 (do buf' <- getSomeCharacters handle_ buf
247 (\e -> do if isEOFError e
252 #define CHARBUF_UTF32
253 -- #define CHARBUF_UTF16
255 -- NB. performance-critical code: eyeball the Core.
256 unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
257 unpack !buf !r !w acc0
258 | r == w = return acc0
260 withRawBuffer buf $ \pbuf ->
266 -- reverse-order decoding of UTF-16
267 c2 <- peekElemOff pbuf i
268 if (c2 < 0xdc00 || c2 > 0xdffff)
269 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
270 else do c1 <- peekElemOff pbuf (i-1)
271 let c = (fromIntegral c1 - 0xd800) * 0x400 +
272 (fromIntegral c2 - 0xdc00) + 0x10000
273 unpackRB (unsafeChr c : acc) (i-2)
275 c <- peekElemOff pbuf i
276 unpackRB (c:acc) (i-1)
281 -- NB. performance-critical code: eyeball the Core.
282 unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
283 unpack_nl !buf !r !w acc0
284 | r == w = return (acc0, 0)
286 withRawBuffer buf $ \pbuf ->
291 c <- peekElemOff pbuf i
292 if (c == '\n' && i > r)
294 c1 <- peekElemOff pbuf (i-1)
296 then unpackRB ('\n':acc) (i-2)
297 else unpackRB ('\n':acc) (i-1)
299 unpackRB (c:acc) (i-1)
301 c <- peekElemOff pbuf (w-1)
304 -- If the last char is a '\r', we need to know whether or
305 -- not it is followed by a '\n', so leave it in the buffer
306 -- for now and just unpack the rest.
307 str <- unpackRB acc0 (w-2)
310 str <- unpackRB acc0 (w-1)
314 -- -----------------------------------------------------------------------------
317 -- hGetContents on a DuplexHandle only affects the read side: you can
318 -- carry on writing to it afterwards.
320 -- | Computation 'hGetContents' @hdl@ returns the list of characters
321 -- corresponding to the unread portion of the channel or file managed
322 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
323 -- In this state, @hdl@ is effectively closed,
324 -- but items are read from @hdl@ on demand and accumulated in a special
325 -- list returned by 'hGetContents' @hdl@.
327 -- Any operation that fails because a handle is closed,
328 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
329 -- A semi-closed handle becomes closed:
331 -- * if 'hClose' is applied to it;
333 -- * if an I\/O error occurs when reading an item from the handle;
335 -- * or once the entire contents of the handle has been read.
337 -- Once a semi-closed handle becomes closed, the contents of the
338 -- associated list becomes fixed. The contents of this final list is
339 -- only partially specified: it will contain at least all the items of
340 -- the stream that were evaluated prior to the handle becoming closed.
342 -- Any I\/O errors encountered while a handle is semi-closed are simply
345 -- This operation may fail with:
347 -- * 'isEOFError' if the end of file has been reached.
349 hGetContents :: Handle -> IO String
350 hGetContents handle =
351 wantReadableHandle "hGetContents" handle $ \handle_ -> do
352 xs <- lazyRead handle
353 return (handle_{ haType=SemiClosedHandle}, xs )
355 -- Note that someone may close the semi-closed handle (or change its
356 -- buffering), so each time these lazy read functions are pulled on,
357 -- they have to check whether the handle has indeed been closed.
359 lazyRead :: Handle -> IO String
362 withHandle "hGetContents" handle $ \ handle_ -> do
363 case haType handle_ of
364 ClosedHandle -> return (handle_, "")
365 SemiClosedHandle -> lazyReadBuffered handle handle_
367 (IOError (Just handle) IllegalOperation "hGetContents"
368 "illegal handle type" Nothing Nothing)
370 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
371 lazyReadBuffered h handle_@Handle__{..} = do
372 buf <- readIORef haCharBuffer
375 buf'@Buffer{..} <- getSomeCharacters handle_ buf
376 lazy_rest <- lazyRead h
377 (s,r) <- if haInputNL == CRLF
378 then unpack_nl bufRaw bufL bufR lazy_rest
379 else do s <- unpack bufRaw bufL bufR lazy_rest
381 writeIORef haCharBuffer (bufferAdjustL r buf')
384 (\e -> do (handle_', _) <- hClose_help handle_
385 debugIO ("hGetContents caught: " ++ show e)
386 -- We might have a \r cached in CRLF mode. So we
387 -- need to check for that and return it:
388 let r = if isEOFError e
389 then if not (isEmptyBuffer buf)
393 throw (augmentIOError e "hGetContents" h)
398 -- ensure we have some characters in the buffer
399 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
400 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
401 case bufferElems buf of
403 -- buffer empty: read some more
404 0 -> readTextDevice handle_ buf
406 -- if the buffer has a single '\r' in it and we're doing newline
407 -- translation: read some more
408 1 | haInputNL == CRLF -> do
409 (c,_) <- readCharBuf bufRaw bufL
411 then do -- shuffle the '\r' to the beginning. This is only safe
412 -- if we're about to call readTextDevice, otherwise it
413 -- would mess up flushCharBuffer.
414 -- See [note Buffer Flushing], GHC.IO.Handle.Types
415 _ <- writeCharBuf bufRaw 0 '\r'
416 let buf' = buf{ bufL=0, bufR=1 }
417 readTextDevice handle_ buf'
421 -- buffer has some chars in it already: just return it
425 -- ---------------------------------------------------------------------------
428 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
429 -- file or channel managed by @hdl@. Characters may be buffered if
430 -- buffering is enabled for @hdl@.
432 -- This operation may fail with:
434 -- * 'isFullError' if the device is full; or
436 -- * 'isPermissionError' if another system resource limit would be exceeded.
438 hPutChar :: Handle -> Char -> IO ()
439 hPutChar handle c = do
441 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
442 case haBufferMode handle_ of
443 LineBuffering -> hPutcBuffered handle_ True c
444 _other -> hPutcBuffered handle_ False c
446 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
447 hPutcBuffered handle_@Handle__{..} is_line c = do
448 buf <- readIORef haCharBuffer
450 then do buf1 <- if haOutputNL == CRLF
452 buf1 <- putc buf '\r'
458 flushed_buf <- flushWriteBuffer_ handle_ buf1
459 writeIORef haCharBuffer flushed_buf
461 writeIORef haCharBuffer buf1
464 writeIORef haCharBuffer buf1
466 putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
467 debugIO ("putc: " ++ summaryBuffer buf)
468 w' <- writeCharBuf raw w c
469 let buf' = buf{ bufR = w' }
470 if isFullCharBuffer buf'
471 then flushWriteBuffer_ handle_ buf'
474 -- ---------------------------------------------------------------------------
477 -- We go to some trouble to avoid keeping the handle locked while we're
478 -- evaluating the string argument to hPutStr, in case doing so triggers another
479 -- I/O operation on the same handle which would lead to deadlock. The classic
482 -- putStr (trace "hello" "world")
484 -- so the basic scheme is this:
486 -- * copy the string into a fresh buffer,
487 -- * "commit" the buffer to the handle.
489 -- Committing may involve simply copying the contents of the new
490 -- buffer into the handle's buffer, flushing one or both buffers, or
491 -- maybe just swapping the buffers over (if the handle's buffer was
492 -- empty). See commitBuffer below.
494 -- | Computation 'hPutStr' @hdl s@ writes the string
495 -- @s@ to the file or channel managed by @hdl@.
497 -- This operation may fail with:
499 -- * 'isFullError' if the device is full; or
501 -- * 'isPermissionError' if another system resource limit would be exceeded.
503 hPutStr :: Handle -> String -> IO ()
504 hPutStr handle str = do
506 wantWritableHandle "hPutStr" handle $ \h_ -> do
507 bmode <- getSpareBuffer h_
508 return (bmode, haOutputNL h_)
511 (NoBuffering, _) -> do
512 hPutChars handle str -- v. slow, but we don't care
513 (LineBuffering, buf) -> do
514 writeBlocks handle True nl buf str
515 (BlockBuffering _, buf) -> do
516 writeBlocks handle False nl buf str
518 hPutChars :: Handle -> [Char] -> IO ()
519 hPutChars _ [] = return ()
520 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
522 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
523 getSpareBuffer Handle__{haCharBuffer=ref,
528 NoBuffering -> return (mode, error "no buffer!")
530 bufs <- readIORef spare_ref
533 BufferListCons b rest -> do
534 writeIORef spare_ref rest
535 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
537 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
538 return (mode, new_buf)
541 -- NB. performance-critical code: eyeball the Core.
542 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
543 writeBlocks hdl line_buffered nl
544 buf@Buffer{ bufRaw=raw, bufSize=len } s =
546 shoveString :: Int -> [Char] -> IO ()
547 shoveString !n [] = do
548 _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-}
550 shoveString !n (c:cs)
551 -- n+1 so we have enough room to write '\r\n' if necessary
553 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
554 writeBlocks hdl line_buffered nl new_buf (c:cs)
558 n1 <- writeCharBuf raw n '\r'
559 writeCharBuf raw n1 '\n'
564 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
565 writeBlocks hdl line_buffered nl new_buf cs
569 n' <- writeCharBuf raw n c
574 -- -----------------------------------------------------------------------------
575 -- commitBuffer handle buf sz count flush release
577 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
578 -- 'count' bytes of data) to handle (handle must be block or line buffered).
582 -- for block/line buffering,
583 -- 1. If there isn't room in the handle buffer, flush the handle
586 -- 2. If the handle buffer is empty,
588 -- then write buf directly to the device.
589 -- else swap the handle buffer with buf.
591 -- 3. If the handle buffer is non-empty, copy buf into the
592 -- handle buffer. Then, if flush != 0, flush
596 :: Handle -- handle to commit to
597 -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
598 -> Int -- number of bytes of data in buffer
599 -> Bool -- True <=> flush the handle afterward
600 -> Bool -- release the buffer?
603 commitBuffer hdl !raw !sz !count flush release =
604 wantWritableHandle "commitAndReleaseBuffer" hdl $
605 commitBuffer' raw sz count flush release
606 {-# NOINLINE commitBuffer #-}
608 -- Explicitly lambda-lift this function to subvert GHC's full laziness
609 -- optimisations, which otherwise tends to float out subexpressions
610 -- past the \handle, which is really a pessimisation in this case because
611 -- that lambda is a one-shot lambda.
613 -- Don't forget to export the function, to stop it being inlined too
614 -- (this appears to be better than NOINLINE, because the strictness
615 -- analyser still gets to worker-wrapper it).
617 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
619 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
621 commitBuffer' raw sz@(I# _) count@(I# _) flush release
622 handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
624 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
625 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
627 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
631 -- enough room in handle buffer?
632 if (not flush && (size - w > count))
633 -- The > is to be sure that we never exactly fill
634 -- up the buffer, which would require a flush. So
635 -- if copying the new data into the buffer would
636 -- make the buffer full, we just flush the existing
637 -- buffer and the new data immediately, rather than
638 -- copying before flushing.
640 -- not flushing, and there's enough room in the buffer:
641 -- just copy the data in and update bufR.
642 then do withRawBuffer raw $ \praw ->
643 copyToRawBuffer old_raw (w*charSize)
644 praw (fromIntegral (count*charSize))
645 writeIORef ref old_buf{ bufR = w + count }
646 return (emptyBuffer raw sz WriteBuffer)
648 -- else, we have to flush
649 else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
652 Buffer{ bufRaw=raw, bufState=WriteBuffer,
653 bufL=0, bufR=count, bufSize=sz }
655 -- if: (a) we don't have to flush, and
656 -- (b) size(new buffer) == size(old buffer), and
657 -- (c) new buffer is not full,
658 -- we can just just swap them over...
659 if (not flush && sz == size && count /= sz)
661 writeIORef ref this_buf
664 -- otherwise, we have to flush the new data too,
665 -- and start with a fresh buffer
667 -- We're aren't going to use this buffer again
668 -- so we ignore the result of flushWriteBuffer_
669 _ <- flushWriteBuffer_ handle_ this_buf
670 writeIORef ref flushed_buf
671 -- if the sizes were different, then allocate
672 -- a new buffer of the correct size.
674 then return (emptyBuffer raw sz WriteBuffer)
675 else newCharBuffer size WriteBuffer
677 -- release the buffer if necessary
679 Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
680 if release && buf_ret_sz == size
682 spare_bufs <- readIORef spare_buf_ref
683 writeIORef spare_buf_ref
684 (BufferListCons buf_ret_raw spare_bufs)
689 -- ---------------------------------------------------------------------------
690 -- Reading/writing sequences of bytes.
692 -- ---------------------------------------------------------------------------
695 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
696 -- buffer @buf@ to the handle @hdl@. It returns ().
698 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
699 -- writing the bytes directly to the underlying file or device.
701 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
702 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
704 -- This operation may fail with:
706 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
707 -- reading end is closed. (If this is a POSIX system, and the program
708 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
709 -- instead, whose default action is to terminate the program).
711 hPutBuf :: Handle -- handle to write to
712 -> Ptr a -- address of buffer
713 -> Int -- number of bytes of data in buffer
715 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
719 :: Handle -- handle to write to
720 -> Ptr a -- address of buffer
721 -> Int -- number of bytes of data in buffer
722 -> IO Int -- returns: number of bytes written
723 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
725 hPutBuf':: Handle -- handle to write to
726 -> Ptr a -- address of buffer
727 -> Int -- number of bytes of data in buffer
728 -> Bool -- allow blocking?
730 hPutBuf' handle ptr count can_block
731 | count == 0 = return 0
732 | count < 0 = illegalBufferSize handle "hPutBuf" count
734 wantWritableHandle "hPutBuf" handle $
735 \ h_@Handle__{..} -> do
736 debugIO ("hPutBuf count=" ++ show count)
737 -- first flush the Char buffer if it is non-empty, then we
738 -- can work directly with the byte buffer
739 cbuf <- readIORef haCharBuffer
740 when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
742 r <- bufWrite h_ (castPtr ptr) count can_block
744 -- we must flush if this Handle is set to NoBuffering. If
745 -- it is set to LineBuffering, be conservative and flush
746 -- anyway (we didn't check for newlines in the data).
748 BlockBuffering _ -> do return ()
749 _line_or_no_buffering -> do flushWriteBuffer h_
752 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
753 bufWrite h_@Handle__{..} ptr count can_block =
754 seq count $ do -- strictness hack
755 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
756 <- readIORef haByteBuffer
758 -- enough room in handle buffer?
759 if (size - w > count)
760 -- There's enough room in the buffer:
761 -- just copy the data in and update bufR.
762 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
763 copyToRawBuffer old_raw w ptr (fromIntegral count)
764 writeIORef haByteBuffer old_buf{ bufR = w + count }
767 -- else, we have to flush
768 else do debugIO "hPutBuf: flushing first"
769 old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
770 -- TODO: we should do a non-blocking flush here
771 writeIORef haByteBuffer old_buf'
772 -- if we can fit in the buffer, then just loop
774 then bufWrite h_ ptr count can_block
776 then do writeChunk h_ (castPtr ptr) count
778 else writeChunkNonBlocking h_ (castPtr ptr) count
780 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
781 writeChunk h_@Handle__{..} ptr bytes
782 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
783 | otherwise = error "Todo: hPutBuf"
785 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
786 writeChunkNonBlocking h_@Handle__{..} ptr bytes
787 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
788 | otherwise = error "Todo: hPutBuf"
790 -- ---------------------------------------------------------------------------
793 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
794 -- into the buffer @buf@ until either EOF is reached or
795 -- @count@ 8-bit bytes have been read.
796 -- It returns the number of bytes actually read. This may be zero if
797 -- EOF was reached before any data was read (or if @count@ is zero).
799 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
800 -- smaller than @count@.
802 -- If the handle is a pipe or socket, and the writing end
803 -- is closed, 'hGetBuf' will behave as if EOF was reached.
805 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
806 -- on the 'Handle', and reads bytes directly.
808 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
810 | count == 0 = return 0
811 | count < 0 = illegalBufferSize h "hGetBuf" count
813 wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
814 flushCharReadBuffer h_
815 bufRead h_ (castPtr ptr) 0 count
817 -- small reads go through the buffer, large reads are satisfied by
818 -- taking data first from the buffer and then direct from the file
820 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
821 bufRead h_@Handle__{..} ptr so_far count =
822 seq so_far $ seq count $ do -- strictness hack
823 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
825 then if count > sz -- small read?
826 then do rest <- readChunk h_ ptr count
827 return (so_far + rest)
828 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
831 else do writeIORef haByteBuffer buf'
832 bufRead h_ ptr so_far count
837 copyFromRawBuffer ptr raw r count
838 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
839 return (so_far + count)
843 copyFromRawBuffer ptr raw r count
844 writeIORef haByteBuffer buf{ bufL = r + count }
845 return (so_far + count)
848 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
849 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
850 let remaining = count - avail
851 so_far' = so_far + avail
852 ptr' = ptr `plusPtr` avail
855 then bufRead h_ ptr' so_far' remaining
858 rest <- readChunk h_ ptr' remaining
859 return (so_far' + rest)
861 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
862 readChunk h_@Handle__{..} ptr bytes
863 | Just fd <- cast haDevice = loop fd 0 bytes
864 | otherwise = error "ToDo: hGetBuf"
866 loop :: FD -> Int -> Int -> IO Int
867 loop fd off bytes | bytes <= 0 = return off
868 loop fd off bytes = do
869 r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
872 else loop fd (off + r) (bytes - r)
874 -- ---------------------------------------------------------------------------
877 -- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@
878 -- into the buffer @buf@. If there is any data available to read,
879 -- then 'hGetBufSome' returns it immediately; it only blocks if there
880 -- is no data to be read.
882 -- It returns the number of bytes actually read. This may be zero if
883 -- EOF was reached before any data was read (or if @count@ is zero).
885 -- 'hGetBufSome' never raises an EOF exception, instead it returns a value
886 -- smaller than @count@.
888 -- If the handle is a pipe or socket, and the writing end
889 -- is closed, 'hGetBufSome' will behave as if EOF was reached.
891 -- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode'
892 -- on the 'Handle', and reads bytes directly.
894 hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
895 hGetBufSome h ptr count
896 | count == 0 = return 0
897 | count < 0 = illegalBufferSize h "hGetBuf" count
899 wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
900 flushCharReadBuffer h_
901 buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer
903 then if count > sz -- large read?
904 then do RawIO.read (haFD h_) (castPtr ptr) count
905 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
908 else do writeIORef haByteBuffer buf'
909 bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 count
911 bufReadNBEmpty h_ buf (castPtr ptr) 0 count
913 haFD :: Handle__ -> FD
914 haFD h_@Handle__{..} =
915 case cast haDevice of
916 Nothing -> error "not an FD"
919 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
920 -- into the buffer @buf@ until either EOF is reached, or
921 -- @count@ 8-bit bytes have been read, or there is no more data available
922 -- to read immediately.
924 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
925 -- never block waiting for data to become available, instead it returns
926 -- only whatever data is available. To wait for data to arrive before
927 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
929 -- If the handle is a pipe or socket, and the writing end
930 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
932 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
933 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
935 -- NOTE: on Windows, this function does not work correctly; it
936 -- behaves identically to 'hGetBuf'.
938 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
939 hGetBufNonBlocking h ptr count
940 | count == 0 = return 0
941 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
943 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
944 flushCharReadBuffer h_
945 bufReadNonBlocking h_ (castPtr ptr) 0 count
947 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
948 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
949 seq so_far $ seq count $ do -- strictness hack
950 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
952 then bufReadNBEmpty h_ buf ptr so_far count
953 else bufReadNBNonEmpty h_ buf ptr so_far count
955 bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
956 bufReadNBEmpty h_@Handle__{..}
957 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
959 = if count > sz -- large read?
960 then do rest <- readChunkNonBlocking h_ ptr count
961 return (so_far + rest)
962 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
964 Nothing -> return so_far
965 Just 0 -> return so_far
967 writeIORef haByteBuffer buf'
968 bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
969 -- NOTE: new count is min count w'
970 -- so we will just copy the contents of the
971 -- buffer in the recursive call, and not
974 bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
975 bufReadNBNonEmpty h_@Handle__{..}
976 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
982 copyFromRawBuffer ptr raw r count
983 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
984 return (so_far + count)
988 copyFromRawBuffer ptr raw r count
989 writeIORef haByteBuffer buf{ bufL = r + count }
990 return (so_far + count)
993 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
994 let buf' = buf{ bufR=0, bufL=0 }
995 writeIORef haByteBuffer buf'
996 let remaining = count - avail
997 so_far' = so_far + avail
998 ptr' = ptr `plusPtr` avail
1000 bufReadNBEmpty h_ buf' ptr' so_far' remaining
1003 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
1004 readChunkNonBlocking h_@Handle__{..} ptr bytes
1005 | Just fd <- cast haDevice = do
1006 m <- RawIO.readNonBlocking (fd::FD) ptr bytes
1010 | otherwise = error "ToDo: hGetBuf"
1012 -- ---------------------------------------------------------------------------
1015 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
1016 copyToRawBuffer raw off ptr bytes =
1017 withRawBuffer raw $ \praw ->
1018 do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
1021 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
1022 copyFromRawBuffer ptr raw off bytes =
1023 withRawBuffer raw $ \praw ->
1024 do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
1027 foreign import ccall unsafe "memcpy"
1028 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
1030 -----------------------------------------------------------------------------
1033 illegalBufferSize :: Handle -> String -> Int -> IO a
1034 illegalBufferSize handle fn sz =
1035 ioException (IOError (Just handle)
1037 ("illegal buffer size " ++ showsPrec 9 sz [])