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, 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.
68 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
70 -- This operation may fail with:
72 -- * 'isEOFError' if the end of file has been reached.
74 -- NOTE for GHC users: unless you use the @-threaded@ flag,
75 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
76 -- threads for the duration of the call. It behaves like a
77 -- @safe@ foreign call in this respect.
79 hWaitForInput :: Handle -> Int -> IO Bool
80 hWaitForInput h msecs = do
81 wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
82 cbuf <- readIORef haCharBuffer
84 if not (isEmptyBuffer cbuf) then return True else do
87 then do cbuf' <- readTextDevice handle_ cbuf
88 writeIORef haCharBuffer cbuf'
91 -- there might be bytes in the byte buffer waiting to be decoded
92 cbuf' <- readTextDeviceNonBlocking handle_ cbuf
93 writeIORef haCharBuffer cbuf'
95 if not (isEmptyBuffer cbuf') then return True else do
97 r <- IODevice.ready haDevice False{-read-} msecs
98 if r then do -- Call hLookAhead' to throw an EOF
99 -- exception if appropriate
100 _ <- hLookAhead_ handle_
103 -- XXX we should only return when there are full characters
104 -- not when there are only bytes. That would mean looping
105 -- and re-running IODevice.ready if we don't have any full
106 -- characters; but we don't know how long we've waited
109 -- ---------------------------------------------------------------------------
112 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
113 -- channel managed by @hdl@, blocking until a character is available.
115 -- This operation may fail with:
117 -- * 'isEOFError' if the end of file has been reached.
119 hGetChar :: Handle -> IO Char
121 wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
123 -- buffering mode makes no difference: we just read whatever is available
124 -- from the device (blocking only if there is nothing available), and then
125 -- return the first character.
126 -- See [note Buffered Reading] in GHC.IO.Handle.Types
127 buf0 <- readIORef haCharBuffer
129 buf1 <- if isEmptyBuffer buf0
130 then readTextDevice handle_ buf0
133 (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
134 let buf2 = bufferAdjustL i buf1
136 if haInputNL == CRLF && c1 == '\r'
138 mbuf3 <- if isEmptyBuffer buf2
139 then maybeFillReadBuffer handle_ buf2
140 else return (Just buf2)
143 -- EOF, so just return the '\r' we have
145 writeIORef haCharBuffer buf2
148 (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
151 writeIORef haCharBuffer (bufferAdjustL i2 buf3)
154 -- not a \r\n sequence, so just return the \r
155 writeIORef haCharBuffer buf3
158 writeIORef haCharBuffer buf2
161 -- ---------------------------------------------------------------------------
164 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
167 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
168 -- channel managed by @hdl@.
170 -- This operation may fail with:
172 -- * 'isEOFError' if the end of file is encountered when reading
173 -- the /first/ character of the line.
175 -- If 'hGetLine' encounters end-of-file at any other point while reading
176 -- in a line, it is treated as a line terminator and the (partial)
179 hGetLine :: Handle -> IO String
181 wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
182 hGetLineBuffered handle_
184 hGetLineBuffered :: Handle__ -> IO String
185 hGetLineBuffered handle_@Handle__{..} = do
186 buf <- readIORef haCharBuffer
187 hGetLineBufferedLoop handle_ buf []
189 hGetLineBufferedLoop :: Handle__
190 -> CharBuffer -> [String]
192 hGetLineBufferedLoop handle_@Handle__{..}
193 buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
195 -- find the end-of-line character, if there is one
197 | r == w = return (False, w)
199 (c,r') <- readCharBuf raw r
201 then return (True, r) -- NB. not r': don't include the '\n'
204 (eol, off) <- loop raw0 r0
206 debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
208 (xs,r') <- if haInputNL == CRLF
209 then unpack_nl raw0 r0 off ""
210 else do xs <- unpack raw0 r0 off ""
213 -- if eol == True, then off is the offset of the '\n'
214 -- otherwise off == w and the buffer is now empty.
216 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
217 return (concat (reverse (xs:xss)))
219 let buf1 = bufferAdjustL r' buf
220 maybe_buf <- maybeFillReadBuffer handle_ buf1
222 -- Nothing indicates we caught an EOF, and we may have a
223 -- partial line to return.
225 -- we reached EOF. There might be a lone \r left
226 -- in the buffer, so check for that and
227 -- append it to the line if necessary.
229 let pre = if not (isEmptyBuffer buf1) then "\r" else ""
230 writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
231 let str = concat (reverse (pre:xs:xss))
236 hGetLineBufferedLoop handle_ new_buf (xs:xss)
238 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
239 maybeFillReadBuffer handle_ buf
241 (do buf' <- getSomeCharacters handle_ buf
244 (\e -> do if isEOFError e
249 #define CHARBUF_UTF32
250 -- #define CHARBUF_UTF16
252 -- NB. performance-critical code: eyeball the Core.
253 unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
254 unpack !buf !r !w acc0
255 | r == w = return acc0
257 withRawBuffer buf $ \pbuf ->
263 -- reverse-order decoding of UTF-16
264 c2 <- peekElemOff pbuf i
265 if (c2 < 0xdc00 || c2 > 0xdffff)
266 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
267 else do c1 <- peekElemOff pbuf (i-1)
268 let c = (fromIntegral c1 - 0xd800) * 0x400 +
269 (fromIntegral c2 - 0xdc00) + 0x10000
270 unpackRB (unsafeChr c : acc) (i-2)
272 c <- peekElemOff pbuf i
273 unpackRB (c:acc) (i-1)
278 -- NB. performance-critical code: eyeball the Core.
279 unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
280 unpack_nl !buf !r !w acc0
281 | r == w = return (acc0, 0)
283 withRawBuffer buf $ \pbuf ->
288 c <- peekElemOff pbuf i
289 if (c == '\n' && i > r)
291 c1 <- peekElemOff pbuf (i-1)
293 then unpackRB ('\n':acc) (i-2)
294 else unpackRB ('\n':acc) (i-1)
296 unpackRB (c:acc) (i-1)
298 c <- peekElemOff pbuf (w-1)
301 -- If the last char is a '\r', we need to know whether or
302 -- not it is followed by a '\n', so leave it in the buffer
303 -- for now and just unpack the rest.
304 str <- unpackRB acc0 (w-2)
307 str <- unpackRB acc0 (w-1)
311 -- -----------------------------------------------------------------------------
314 -- hGetContents on a DuplexHandle only affects the read side: you can
315 -- carry on writing to it afterwards.
317 -- | Computation 'hGetContents' @hdl@ returns the list of characters
318 -- corresponding to the unread portion of the channel or file managed
319 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
320 -- In this state, @hdl@ is effectively closed,
321 -- but items are read from @hdl@ on demand and accumulated in a special
322 -- list returned by 'hGetContents' @hdl@.
324 -- Any operation that fails because a handle is closed,
325 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
326 -- A semi-closed handle becomes closed:
328 -- * if 'hClose' is applied to it;
330 -- * if an I\/O error occurs when reading an item from the handle;
332 -- * or once the entire contents of the handle has been read.
334 -- Once a semi-closed handle becomes closed, the contents of the
335 -- associated list becomes fixed. The contents of this final list is
336 -- only partially specified: it will contain at least all the items of
337 -- the stream that were evaluated prior to the handle becoming closed.
339 -- Any I\/O errors encountered while a handle is semi-closed are simply
342 -- This operation may fail with:
344 -- * 'isEOFError' if the end of file has been reached.
346 hGetContents :: Handle -> IO String
347 hGetContents handle =
348 wantReadableHandle "hGetContents" handle $ \handle_ -> do
349 xs <- lazyRead handle
350 return (handle_{ haType=SemiClosedHandle}, xs )
352 -- Note that someone may close the semi-closed handle (or change its
353 -- buffering), so each time these lazy read functions are pulled on,
354 -- they have to check whether the handle has indeed been closed.
356 lazyRead :: Handle -> IO String
359 withHandle "hGetContents" handle $ \ handle_ -> do
360 case haType handle_ of
361 ClosedHandle -> return (handle_, "")
362 SemiClosedHandle -> lazyReadBuffered handle handle_
364 (IOError (Just handle) IllegalOperation "hGetContents"
365 "illegal handle type" Nothing Nothing)
367 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
368 lazyReadBuffered h handle_@Handle__{..} = do
369 buf <- readIORef haCharBuffer
372 buf'@Buffer{..} <- getSomeCharacters handle_ buf
373 lazy_rest <- lazyRead h
374 (s,r) <- if haInputNL == CRLF
375 then unpack_nl bufRaw bufL bufR lazy_rest
376 else do s <- unpack bufRaw bufL bufR lazy_rest
378 writeIORef haCharBuffer (bufferAdjustL r buf')
381 (\e -> do (handle_', _) <- hClose_help handle_
382 debugIO ("hGetContents caught: " ++ show e)
383 -- We might have a \r cached in CRLF mode. So we
384 -- need to check for that and return it:
385 let r = if isEOFError e
386 then if not (isEmptyBuffer buf)
390 throw (augmentIOError e "hGetContents" h)
395 -- ensure we have some characters in the buffer
396 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
397 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
398 case bufferElems buf of
400 -- buffer empty: read some more
401 0 -> readTextDevice handle_ buf
403 -- if the buffer has a single '\r' in it and we're doing newline
404 -- translation: read some more
405 1 | haInputNL == CRLF -> do
406 (c,_) <- readCharBuf bufRaw bufL
408 then do -- shuffle the '\r' to the beginning. This is only safe
409 -- if we're about to call readTextDevice, otherwise it
410 -- would mess up flushCharBuffer.
411 -- See [note Buffer Flushing], GHC.IO.Handle.Types
412 _ <- writeCharBuf bufRaw 0 '\r'
413 let buf' = buf{ bufL=0, bufR=1 }
414 readTextDevice handle_ buf'
418 -- buffer has some chars in it already: just return it
422 -- ---------------------------------------------------------------------------
425 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
426 -- file or channel managed by @hdl@. Characters may be buffered if
427 -- buffering is enabled for @hdl@.
429 -- This operation may fail with:
431 -- * 'isFullError' if the device is full; or
433 -- * 'isPermissionError' if another system resource limit would be exceeded.
435 hPutChar :: Handle -> Char -> IO ()
436 hPutChar handle c = do
438 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
439 case haBufferMode handle_ of
440 LineBuffering -> hPutcBuffered handle_ True c
441 _other -> hPutcBuffered handle_ False c
443 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
444 hPutcBuffered handle_@Handle__{..} is_line c = do
445 buf <- readIORef haCharBuffer
447 then do buf1 <- if haOutputNL == CRLF
449 buf1 <- putc buf '\r'
455 flushed_buf <- flushWriteBuffer_ handle_ buf1
456 writeIORef haCharBuffer flushed_buf
458 writeIORef haCharBuffer buf1
461 writeIORef haCharBuffer buf1
463 putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
464 debugIO ("putc: " ++ summaryBuffer buf)
465 w' <- writeCharBuf raw w c
466 let buf' = buf{ bufR = w' }
467 if isFullCharBuffer buf'
468 then flushWriteBuffer_ handle_ buf'
471 -- ---------------------------------------------------------------------------
474 -- We go to some trouble to avoid keeping the handle locked while we're
475 -- evaluating the string argument to hPutStr, in case doing so triggers another
476 -- I/O operation on the same handle which would lead to deadlock. The classic
479 -- putStr (trace "hello" "world")
481 -- so the basic scheme is this:
483 -- * copy the string into a fresh buffer,
484 -- * "commit" the buffer to the handle.
486 -- Committing may involve simply copying the contents of the new
487 -- buffer into the handle's buffer, flushing one or both buffers, or
488 -- maybe just swapping the buffers over (if the handle's buffer was
489 -- empty). See commitBuffer below.
491 -- | Computation 'hPutStr' @hdl s@ writes the string
492 -- @s@ to the file or channel managed by @hdl@.
494 -- This operation may fail with:
496 -- * 'isFullError' if the device is full; or
498 -- * 'isPermissionError' if another system resource limit would be exceeded.
500 hPutStr :: Handle -> String -> IO ()
501 hPutStr handle str = do
503 wantWritableHandle "hPutStr" handle $ \h_ -> do
504 bmode <- getSpareBuffer h_
505 return (bmode, haOutputNL h_)
508 (NoBuffering, _) -> do
509 hPutChars handle str -- v. slow, but we don't care
510 (LineBuffering, buf) -> do
511 writeBlocks handle True nl buf str
512 (BlockBuffering _, buf) -> do
513 writeBlocks handle False nl buf str
515 hPutChars :: Handle -> [Char] -> IO ()
516 hPutChars _ [] = return ()
517 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
519 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
520 getSpareBuffer Handle__{haCharBuffer=ref,
525 NoBuffering -> return (mode, error "no buffer!")
527 bufs <- readIORef spare_ref
530 BufferListCons b rest -> do
531 writeIORef spare_ref rest
532 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
534 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
535 return (mode, new_buf)
538 -- NB. performance-critical code: eyeball the Core.
539 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
540 writeBlocks hdl line_buffered nl
541 buf@Buffer{ bufRaw=raw, bufSize=len } s =
543 shoveString :: Int -> [Char] -> IO ()
544 shoveString !n [] = do
545 _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-}
547 shoveString !n (c:cs)
548 -- n+1 so we have enough room to write '\r\n' if necessary
550 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
551 writeBlocks hdl line_buffered nl new_buf (c:cs)
555 n1 <- writeCharBuf raw n '\r'
556 writeCharBuf raw n1 '\n'
561 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
562 writeBlocks hdl line_buffered nl new_buf cs
566 n' <- writeCharBuf raw n c
571 -- -----------------------------------------------------------------------------
572 -- commitBuffer handle buf sz count flush release
574 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
575 -- 'count' bytes of data) to handle (handle must be block or line buffered).
579 -- for block/line buffering,
580 -- 1. If there isn't room in the handle buffer, flush the handle
583 -- 2. If the handle buffer is empty,
585 -- then write buf directly to the device.
586 -- else swap the handle buffer with buf.
588 -- 3. If the handle buffer is non-empty, copy buf into the
589 -- handle buffer. Then, if flush != 0, flush
593 :: Handle -- handle to commit to
594 -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
595 -> Int -- number of bytes of data in buffer
596 -> Bool -- True <=> flush the handle afterward
597 -> Bool -- release the buffer?
600 commitBuffer hdl !raw !sz !count flush release =
601 wantWritableHandle "commitAndReleaseBuffer" hdl $
602 commitBuffer' raw sz count flush release
603 {-# NOINLINE commitBuffer #-}
605 -- Explicitly lambda-lift this function to subvert GHC's full laziness
606 -- optimisations, which otherwise tends to float out subexpressions
607 -- past the \handle, which is really a pessimisation in this case because
608 -- that lambda is a one-shot lambda.
610 -- Don't forget to export the function, to stop it being inlined too
611 -- (this appears to be better than NOINLINE, because the strictness
612 -- analyser still gets to worker-wrapper it).
614 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
616 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
618 commitBuffer' raw sz@(I# _) count@(I# _) flush release
619 handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
621 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
622 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
624 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
628 -- enough room in handle buffer?
629 if (not flush && (size - w > count))
630 -- The > is to be sure that we never exactly fill
631 -- up the buffer, which would require a flush. So
632 -- if copying the new data into the buffer would
633 -- make the buffer full, we just flush the existing
634 -- buffer and the new data immediately, rather than
635 -- copying before flushing.
637 -- not flushing, and there's enough room in the buffer:
638 -- just copy the data in and update bufR.
639 then do withRawBuffer raw $ \praw ->
640 copyToRawBuffer old_raw (w*charSize)
641 praw (fromIntegral (count*charSize))
642 writeIORef ref old_buf{ bufR = w + count }
643 return (emptyBuffer raw sz WriteBuffer)
645 -- else, we have to flush
646 else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
649 Buffer{ bufRaw=raw, bufState=WriteBuffer,
650 bufL=0, bufR=count, bufSize=sz }
652 -- if: (a) we don't have to flush, and
653 -- (b) size(new buffer) == size(old buffer), and
654 -- (c) new buffer is not full,
655 -- we can just just swap them over...
656 if (not flush && sz == size && count /= sz)
658 writeIORef ref this_buf
661 -- otherwise, we have to flush the new data too,
662 -- and start with a fresh buffer
664 -- We're aren't going to use this buffer again
665 -- so we ignore the result of flushWriteBuffer_
666 _ <- flushWriteBuffer_ handle_ this_buf
667 writeIORef ref flushed_buf
668 -- if the sizes were different, then allocate
669 -- a new buffer of the correct size.
671 then return (emptyBuffer raw sz WriteBuffer)
672 else newCharBuffer size WriteBuffer
674 -- release the buffer if necessary
676 Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
677 if release && buf_ret_sz == size
679 spare_bufs <- readIORef spare_buf_ref
680 writeIORef spare_buf_ref
681 (BufferListCons buf_ret_raw spare_bufs)
686 -- ---------------------------------------------------------------------------
687 -- Reading/writing sequences of bytes.
689 -- ---------------------------------------------------------------------------
692 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
693 -- buffer @buf@ to the handle @hdl@. It returns ().
695 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
696 -- writing the bytes directly to the underlying file or device.
698 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
699 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
701 -- This operation may fail with:
703 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
704 -- reading end is closed. (If this is a POSIX system, and the program
705 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
706 -- instead, whose default action is to terminate the program).
708 hPutBuf :: Handle -- handle to write to
709 -> Ptr a -- address of buffer
710 -> Int -- number of bytes of data in buffer
712 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
716 :: Handle -- handle to write to
717 -> Ptr a -- address of buffer
718 -> Int -- number of bytes of data in buffer
719 -> IO Int -- returns: number of bytes written
720 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
722 hPutBuf':: Handle -- handle to write to
723 -> Ptr a -- address of buffer
724 -> Int -- number of bytes of data in buffer
725 -> Bool -- allow blocking?
727 hPutBuf' handle ptr count can_block
728 | count == 0 = return 0
729 | count < 0 = illegalBufferSize handle "hPutBuf" count
731 wantWritableHandle "hPutBuf" handle $
732 \ h_@Handle__{..} -> do
733 debugIO ("hPutBuf count=" ++ show count)
734 -- first flush the Char buffer if it is non-empty, then we
735 -- can work directly with the byte buffer
736 cbuf <- readIORef haCharBuffer
737 when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
739 r <- bufWrite h_ (castPtr ptr) count can_block
741 -- we must flush if this Handle is set to NoBuffering. If
742 -- it is set to LineBuffering, be conservative and flush
743 -- anyway (we didn't check for newlines in the data).
745 BlockBuffering _ -> do return ()
746 _line_or_no_buffering -> do flushWriteBuffer h_
749 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
750 bufWrite h_@Handle__{..} ptr count can_block =
751 seq count $ do -- strictness hack
752 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
753 <- readIORef haByteBuffer
755 -- enough room in handle buffer?
756 if (size - w > count)
757 -- There's enough room in the buffer:
758 -- just copy the data in and update bufR.
759 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
760 copyToRawBuffer old_raw w ptr (fromIntegral count)
761 writeIORef haByteBuffer old_buf{ bufR = w + count }
764 -- else, we have to flush
765 else do debugIO "hPutBuf: flushing first"
766 old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
767 -- TODO: we should do a non-blocking flush here
768 writeIORef haByteBuffer old_buf'
769 -- if we can fit in the buffer, then just loop
771 then bufWrite h_ ptr count can_block
773 then do writeChunk h_ (castPtr ptr) count
775 else writeChunkNonBlocking h_ (castPtr ptr) count
777 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
778 writeChunk h_@Handle__{..} ptr bytes
779 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
780 | otherwise = error "Todo: hPutBuf"
782 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
783 writeChunkNonBlocking h_@Handle__{..} ptr bytes
784 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
785 | otherwise = error "Todo: hPutBuf"
787 -- ---------------------------------------------------------------------------
790 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
791 -- into the buffer @buf@ until either EOF is reached or
792 -- @count@ 8-bit bytes have been read.
793 -- It returns the number of bytes actually read. This may be zero if
794 -- EOF was reached before any data was read (or if @count@ is zero).
796 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
797 -- using, and reads bytes directly from the underlying IO device.
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 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
875 -- into the buffer @buf@ until either EOF is reached, or
876 -- @count@ 8-bit bytes have been read, or there is no more data available
877 -- to read immediately.
879 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
880 -- never block waiting for data to become available, instead it returns
881 -- only whatever data is available. To wait for data to arrive before
882 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
884 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
885 -- is currently using, and reads bytes directly from the underlying IO
888 -- If the handle is a pipe or socket, and the writing end
889 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
891 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
892 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
894 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
895 hGetBufNonBlocking h ptr count
896 | count == 0 = return 0
897 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
899 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
900 flushCharReadBuffer h_
901 bufReadNonBlocking h_ (castPtr ptr) 0 count
903 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
904 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
905 seq so_far $ seq count $ do -- strictness hack
906 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
908 then if count > sz -- large read?
909 then do rest <- readChunkNonBlocking h_ ptr count
910 return (so_far + rest)
911 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
913 Nothing -> return so_far
914 Just 0 -> return so_far
916 writeIORef haByteBuffer buf'
917 bufReadNonBlocking h_ ptr so_far (min count r)
918 -- NOTE: new count is min count w'
919 -- so we will just copy the contents of the
920 -- buffer in the recursive call, and not
926 copyFromRawBuffer ptr raw r count
927 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
928 return (so_far + count)
932 copyFromRawBuffer ptr raw r count
933 writeIORef haByteBuffer buf{ bufL = r + count }
934 return (so_far + count)
937 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
938 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
939 let remaining = count - avail
940 so_far' = so_far + avail
941 ptr' = ptr `plusPtr` avail
943 -- we haven't attempted to read anything yet if we get to here.
945 then bufReadNonBlocking h_ ptr' so_far' remaining
948 rest <- readChunkNonBlocking h_ ptr' remaining
949 return (so_far' + rest)
952 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
953 readChunkNonBlocking h_@Handle__{..} ptr bytes
954 | Just fd <- cast haDevice = do
955 m <- RawIO.readNonBlocking (fd::FD) ptr bytes
959 | otherwise = error "ToDo: hGetBuf"
961 -- ---------------------------------------------------------------------------
964 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
965 copyToRawBuffer raw off ptr bytes =
966 withRawBuffer raw $ \praw ->
967 do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
970 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
971 copyFromRawBuffer ptr raw off bytes =
972 withRawBuffer raw $ \praw ->
973 do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
976 foreign import ccall unsafe "memcpy"
977 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
979 -----------------------------------------------------------------------------
982 illegalBufferSize :: Handle -> String -> Int -> IO a
983 illegalBufferSize handle fn sz =
984 ioException (IOError (Just handle)
986 ("illegal buffer size " ++ showsPrec 9 sz [])