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
34 import GHC.IO.Handle.Types
35 import GHC.IO.Handle.Internals
36 import qualified GHC.IO.Device as IODevice
37 import qualified GHC.IO.Device as RawIO
43 import System.IO.Error
54 -- ---------------------------------------------------------------------------
55 -- Simple input operations
57 -- If hWaitForInput finds anything in the Handle's buffer, it
58 -- immediately returns. If not, it tries to read from the underlying
59 -- OS handle. Notice that for buffered Handles connected to terminals
60 -- this means waiting until a complete line is available.
62 -- | Computation 'hWaitForInput' @hdl t@
63 -- waits until input is available on handle @hdl@.
64 -- It returns 'True' as soon as input is available on @hdl@,
65 -- or 'False' if no input is available within @t@ milliseconds.
67 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
69 -- This operation may fail with:
71 -- * 'isEOFError' if the end of file has been reached.
73 -- NOTE for GHC users: unless you use the @-threaded@ flag,
74 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
75 -- threads for the duration of the call. It behaves like a
76 -- @safe@ foreign call in this respect.
78 hWaitForInput :: Handle -> Int -> IO Bool
79 hWaitForInput h msecs = do
80 wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
81 cbuf <- readIORef haCharBuffer
83 if not (isEmptyBuffer cbuf) then return True else do
86 then do cbuf' <- readTextDevice handle_ cbuf
87 writeIORef haCharBuffer cbuf'
90 -- there might be bytes in the byte buffer waiting to be decoded
91 cbuf' <- readTextDeviceNonBlocking handle_ cbuf
92 writeIORef haCharBuffer cbuf'
94 if not (isEmptyBuffer cbuf') then return True else do
96 r <- IODevice.ready haDevice False{-read-} msecs
97 if r then do -- Call hLookAhead' to throw an EOF
98 -- exception if appropriate
99 _ <- hLookAhead_ handle_
102 -- XXX we should only return when there are full characters
103 -- not when there are only bytes. That would mean looping
104 -- and re-running IODevice.ready if we don't have any full
105 -- characters; but we don't know how long we've waited
108 -- ---------------------------------------------------------------------------
111 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
112 -- channel managed by @hdl@, blocking until a character is available.
114 -- This operation may fail with:
116 -- * 'isEOFError' if the end of file has been reached.
118 hGetChar :: Handle -> IO Char
120 wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
122 -- buffering mode makes no difference: we just read whatever is available
123 -- from the device (blocking only if there is nothing available), and then
124 -- return the first character.
125 -- See [note Buffered Reading] in GHC.IO.Handle.Types
126 buf0 <- readIORef haCharBuffer
128 buf1 <- if isEmptyBuffer buf0
129 then readTextDevice handle_ buf0
132 (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
133 let buf2 = bufferAdjustL i buf1
135 if haInputNL == CRLF && c1 == '\r'
137 mbuf3 <- if isEmptyBuffer buf2
138 then maybeFillReadBuffer handle_ buf2
139 else return (Just buf2)
142 -- EOF, so just return the '\r' we have
144 writeIORef haCharBuffer buf2
147 (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
150 writeIORef haCharBuffer (bufferAdjustL i2 buf3)
153 -- not a \r\n sequence, so just return the \r
154 writeIORef haCharBuffer buf3
157 writeIORef haCharBuffer buf2
160 -- ---------------------------------------------------------------------------
163 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
166 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
167 -- channel managed by @hdl@.
169 -- This operation may fail with:
171 -- * 'isEOFError' if the end of file is encountered when reading
172 -- the /first/ character of the line.
174 -- If 'hGetLine' encounters end-of-file at any other point while reading
175 -- in a line, it is treated as a line terminator and the (partial)
178 hGetLine :: Handle -> IO String
180 wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
181 hGetLineBuffered handle_
183 hGetLineBuffered :: Handle__ -> IO String
184 hGetLineBuffered handle_@Handle__{..} = do
185 buf <- readIORef haCharBuffer
186 hGetLineBufferedLoop handle_ buf []
188 hGetLineBufferedLoop :: Handle__
189 -> CharBuffer -> [String]
191 hGetLineBufferedLoop handle_@Handle__{..}
192 buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
194 -- find the end-of-line character, if there is one
196 | r == w = return (False, w)
198 (c,r') <- readCharBuf raw r
200 then return (True, r) -- NB. not r': don't include the '\n'
203 (eol, off) <- loop raw0 r0
205 debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
207 (xs,r') <- if haInputNL == CRLF
208 then unpack_nl raw0 r0 off ""
209 else do xs <- unpack raw0 r0 off ""
212 -- if eol == True, then off is the offset of the '\n'
213 -- otherwise off == w and the buffer is now empty.
215 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
216 return (concat (reverse (xs:xss)))
218 let buf1 = bufferAdjustL r' buf
219 maybe_buf <- maybeFillReadBuffer handle_ buf1
221 -- Nothing indicates we caught an EOF, and we may have a
222 -- partial line to return.
224 -- we reached EOF. There might be a lone \r left
225 -- in the buffer, so check for that and
226 -- append it to the line if necessary.
228 let pre = if not (isEmptyBuffer buf1) then "\r" else ""
229 writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
230 let str = concat (reverse (pre:xs:xss))
235 hGetLineBufferedLoop handle_ new_buf (xs:xss)
237 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
238 maybeFillReadBuffer handle_ buf
240 (do buf' <- getSomeCharacters handle_ buf
243 (\e -> do if isEOFError e
248 #define CHARBUF_UTF32
249 -- #define CHARBUF_UTF16
251 -- NB. performance-critical code: eyeball the Core.
252 unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
253 unpack !buf !r !w acc0
254 | r == w = return acc0
256 withRawBuffer buf $ \pbuf ->
262 -- reverse-order decoding of UTF-16
263 c2 <- peekElemOff pbuf i
264 if (c2 < 0xdc00 || c2 > 0xdffff)
265 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
266 else do c1 <- peekElemOff pbuf (i-1)
267 let c = (fromIntegral c1 - 0xd800) * 0x400 +
268 (fromIntegral c2 - 0xdc00) + 0x10000
269 unpackRB (unsafeChr c : acc) (i-2)
271 c <- peekElemOff pbuf i
272 unpackRB (c:acc) (i-1)
277 -- NB. performance-critical code: eyeball the Core.
278 unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
279 unpack_nl !buf !r !w acc0
280 | r == w = return (acc0, 0)
282 withRawBuffer buf $ \pbuf ->
287 c <- peekElemOff pbuf i
288 if (c == '\n' && i > r)
290 c1 <- peekElemOff pbuf (i-1)
292 then unpackRB ('\n':acc) (i-2)
293 else unpackRB ('\n':acc) (i-1)
295 unpackRB (c:acc) (i-1)
297 c <- peekElemOff pbuf (w-1)
300 -- If the last char is a '\r', we need to know whether or
301 -- not it is followed by a '\n', so leave it in the buffer
302 -- for now and just unpack the rest.
303 str <- unpackRB acc0 (w-2)
306 str <- unpackRB acc0 (w-1)
310 -- -----------------------------------------------------------------------------
313 -- hGetContents on a DuplexHandle only affects the read side: you can
314 -- carry on writing to it afterwards.
316 -- | Computation 'hGetContents' @hdl@ returns the list of characters
317 -- corresponding to the unread portion of the channel or file managed
318 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
319 -- In this state, @hdl@ is effectively closed,
320 -- but items are read from @hdl@ on demand and accumulated in a special
321 -- list returned by 'hGetContents' @hdl@.
323 -- Any operation that fails because a handle is closed,
324 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
325 -- A semi-closed handle becomes closed:
327 -- * if 'hClose' is applied to it;
329 -- * if an I\/O error occurs when reading an item from the handle;
331 -- * or once the entire contents of the handle has been read.
333 -- Once a semi-closed handle becomes closed, the contents of the
334 -- associated list becomes fixed. The contents of this final list is
335 -- only partially specified: it will contain at least all the items of
336 -- the stream that were evaluated prior to the handle becoming closed.
338 -- Any I\/O errors encountered while a handle is semi-closed are simply
341 -- This operation may fail with:
343 -- * 'isEOFError' if the end of file has been reached.
345 hGetContents :: Handle -> IO String
346 hGetContents handle =
347 wantReadableHandle "hGetContents" handle $ \handle_ -> do
348 xs <- lazyRead handle
349 return (handle_{ haType=SemiClosedHandle}, xs )
351 -- Note that someone may close the semi-closed handle (or change its
352 -- buffering), so each time these lazy read functions are pulled on,
353 -- they have to check whether the handle has indeed been closed.
355 lazyRead :: Handle -> IO String
358 withHandle "lazyRead" handle $ \ handle_ -> do
359 case haType handle_ of
360 ClosedHandle -> return (handle_, "")
361 SemiClosedHandle -> lazyReadBuffered handle handle_
363 (IOError (Just handle) IllegalOperation "lazyRead"
364 "illegal handle type" Nothing Nothing)
366 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
367 lazyReadBuffered h handle_@Handle__{..} = do
368 buf <- readIORef haCharBuffer
371 buf'@Buffer{..} <- getSomeCharacters handle_ buf
372 lazy_rest <- lazyRead h
373 (s,r) <- if haInputNL == CRLF
374 then unpack_nl bufRaw bufL bufR lazy_rest
375 else do s <- unpack bufRaw bufL bufR lazy_rest
377 writeIORef haCharBuffer (bufferAdjustL r buf')
380 -- all I/O errors are discarded. Additionally, we close the handle.
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 if not (isEmptyBuffer buf)
386 then return (handle_', "\r")
387 else return (handle_', "")
390 -- ensure we have some characters in the buffer
391 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
392 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
393 case bufferElems buf of
395 -- buffer empty: read some more
396 0 -> readTextDevice handle_ buf
398 -- if the buffer has a single '\r' in it and we're doing newline
399 -- translation: read some more
400 1 | haInputNL == CRLF -> do
401 (c,_) <- readCharBuf bufRaw bufL
403 then do -- shuffle the '\r' to the beginning. This is only safe
404 -- if we're about to call readTextDevice, otherwise it
405 -- would mess up flushCharBuffer.
406 -- See [note Buffer Flushing], GHC.IO.Handle.Types
407 _ <- writeCharBuf bufRaw 0 '\r'
408 let buf' = buf{ bufL=0, bufR=1 }
409 readTextDevice handle_ buf'
413 -- buffer has some chars in it already: just return it
417 -- ---------------------------------------------------------------------------
420 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
421 -- file or channel managed by @hdl@. Characters may be buffered if
422 -- buffering is enabled for @hdl@.
424 -- This operation may fail with:
426 -- * 'isFullError' if the device is full; or
428 -- * 'isPermissionError' if another system resource limit would be exceeded.
430 hPutChar :: Handle -> Char -> IO ()
431 hPutChar handle c = do
433 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
434 case haBufferMode handle_ of
435 LineBuffering -> hPutcBuffered handle_ True c
436 _other -> hPutcBuffered handle_ False c
438 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
439 hPutcBuffered handle_@Handle__{..} is_line c = do
440 buf <- readIORef haCharBuffer
442 then do buf1 <- if haOutputNL == CRLF
444 buf1 <- putc buf '\r'
450 flushed_buf <- flushWriteBuffer_ handle_ buf1
451 writeIORef haCharBuffer flushed_buf
453 writeIORef haCharBuffer buf1
456 writeIORef haCharBuffer buf1
458 putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
459 debugIO ("putc: " ++ summaryBuffer buf)
460 w' <- writeCharBuf raw w c
461 let buf' = buf{ bufR = w' }
462 if isFullCharBuffer buf'
463 then flushWriteBuffer_ handle_ buf'
466 -- ---------------------------------------------------------------------------
469 -- We go to some trouble to avoid keeping the handle locked while we're
470 -- evaluating the string argument to hPutStr, in case doing so triggers another
471 -- I/O operation on the same handle which would lead to deadlock. The classic
474 -- putStr (trace "hello" "world")
476 -- so the basic scheme is this:
478 -- * copy the string into a fresh buffer,
479 -- * "commit" the buffer to the handle.
481 -- Committing may involve simply copying the contents of the new
482 -- buffer into the handle's buffer, flushing one or both buffers, or
483 -- maybe just swapping the buffers over (if the handle's buffer was
484 -- empty). See commitBuffer below.
486 -- | Computation 'hPutStr' @hdl s@ writes the string
487 -- @s@ to the file or channel managed by @hdl@.
489 -- This operation may fail with:
491 -- * 'isFullError' if the device is full; or
493 -- * 'isPermissionError' if another system resource limit would be exceeded.
495 hPutStr :: Handle -> String -> IO ()
496 hPutStr handle str = do
498 wantWritableHandle "hPutStr" handle $ \h_ -> do
499 bmode <- getSpareBuffer h_
500 return (bmode, haOutputNL h_)
503 (NoBuffering, _) -> do
504 hPutChars handle str -- v. slow, but we don't care
505 (LineBuffering, buf) -> do
506 writeBlocks handle True nl buf str
507 (BlockBuffering _, buf) -> do
508 writeBlocks handle False nl buf str
510 hPutChars :: Handle -> [Char] -> IO ()
511 hPutChars _ [] = return ()
512 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
514 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
515 getSpareBuffer Handle__{haCharBuffer=ref,
520 NoBuffering -> return (mode, error "no buffer!")
522 bufs <- readIORef spare_ref
525 BufferListCons b rest -> do
526 writeIORef spare_ref rest
527 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
529 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
530 return (mode, new_buf)
533 -- NB. performance-critical code: eyeball the Core.
534 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
535 writeBlocks hdl line_buffered nl
536 buf@Buffer{ bufRaw=raw, bufSize=len } s =
538 shoveString :: Int -> [Char] -> IO ()
539 shoveString !n [] = do
540 _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-}
542 shoveString !n (c:cs)
543 -- n+1 so we have enough room to write '\r\n' if necessary
545 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
546 writeBlocks hdl line_buffered nl new_buf (c:cs)
550 n1 <- writeCharBuf raw n '\r'
551 writeCharBuf raw n1 '\n'
556 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
557 writeBlocks hdl line_buffered nl new_buf cs
561 n' <- writeCharBuf raw n c
566 -- -----------------------------------------------------------------------------
567 -- commitBuffer handle buf sz count flush release
569 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
570 -- 'count' bytes of data) to handle (handle must be block or line buffered).
574 -- for block/line buffering,
575 -- 1. If there isn't room in the handle buffer, flush the handle
578 -- 2. If the handle buffer is empty,
580 -- then write buf directly to the device.
581 -- else swap the handle buffer with buf.
583 -- 3. If the handle buffer is non-empty, copy buf into the
584 -- handle buffer. Then, if flush != 0, flush
588 :: Handle -- handle to commit to
589 -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
590 -> Int -- number of bytes of data in buffer
591 -> Bool -- True <=> flush the handle afterward
592 -> Bool -- release the buffer?
595 commitBuffer hdl !raw !sz !count flush release =
596 wantWritableHandle "commitAndReleaseBuffer" hdl $
597 commitBuffer' raw sz count flush release
598 {-# NOINLINE commitBuffer #-}
600 -- Explicitly lambda-lift this function to subvert GHC's full laziness
601 -- optimisations, which otherwise tends to float out subexpressions
602 -- past the \handle, which is really a pessimisation in this case because
603 -- that lambda is a one-shot lambda.
605 -- Don't forget to export the function, to stop it being inlined too
606 -- (this appears to be better than NOINLINE, because the strictness
607 -- analyser still gets to worker-wrapper it).
609 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
611 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
613 commitBuffer' raw sz@(I# _) count@(I# _) flush release
614 handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
616 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
617 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
619 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
623 -- enough room in handle buffer?
624 if (not flush && (size - w > count))
625 -- The > is to be sure that we never exactly fill
626 -- up the buffer, which would require a flush. So
627 -- if copying the new data into the buffer would
628 -- make the buffer full, we just flush the existing
629 -- buffer and the new data immediately, rather than
630 -- copying before flushing.
632 -- not flushing, and there's enough room in the buffer:
633 -- just copy the data in and update bufR.
634 then do withRawBuffer raw $ \praw ->
635 copyToRawBuffer old_raw (w*charSize)
636 praw (fromIntegral (count*charSize))
637 writeIORef ref old_buf{ bufR = w + count }
638 return (emptyBuffer raw sz WriteBuffer)
640 -- else, we have to flush
641 else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
644 Buffer{ bufRaw=raw, bufState=WriteBuffer,
645 bufL=0, bufR=count, bufSize=sz }
647 -- if: (a) we don't have to flush, and
648 -- (b) size(new buffer) == size(old buffer), and
649 -- (c) new buffer is not full,
650 -- we can just just swap them over...
651 if (not flush && sz == size && count /= sz)
653 writeIORef ref this_buf
656 -- otherwise, we have to flush the new data too,
657 -- and start with a fresh buffer
659 -- We're aren't going to use this buffer again
660 -- so we ignore the result of flushWriteBuffer_
661 _ <- flushWriteBuffer_ handle_ this_buf
662 writeIORef ref flushed_buf
663 -- if the sizes were different, then allocate
664 -- a new buffer of the correct size.
666 then return (emptyBuffer raw sz WriteBuffer)
667 else newCharBuffer size WriteBuffer
669 -- release the buffer if necessary
671 Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
672 if release && buf_ret_sz == size
674 spare_bufs <- readIORef spare_buf_ref
675 writeIORef spare_buf_ref
676 (BufferListCons buf_ret_raw spare_bufs)
681 -- ---------------------------------------------------------------------------
682 -- Reading/writing sequences of bytes.
684 -- ---------------------------------------------------------------------------
687 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
688 -- buffer @buf@ to the handle @hdl@. It returns ().
690 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
691 -- writing the bytes directly to the underlying file or device.
693 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
694 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
696 -- This operation may fail with:
698 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
699 -- reading end is closed. (If this is a POSIX system, and the program
700 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
701 -- instead, whose default action is to terminate the program).
703 hPutBuf :: Handle -- handle to write to
704 -> Ptr a -- address of buffer
705 -> Int -- number of bytes of data in buffer
707 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
711 :: Handle -- handle to write to
712 -> Ptr a -- address of buffer
713 -> Int -- number of bytes of data in buffer
714 -> IO Int -- returns: number of bytes written
715 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
717 hPutBuf':: Handle -- handle to write to
718 -> Ptr a -- address of buffer
719 -> Int -- number of bytes of data in buffer
720 -> Bool -- allow blocking?
722 hPutBuf' handle ptr count can_block
723 | count == 0 = return 0
724 | count < 0 = illegalBufferSize handle "hPutBuf" count
726 wantWritableHandle "hPutBuf" handle $
727 \ h_@Handle__{..} -> do
728 debugIO ("hPutBuf count=" ++ show count)
729 -- first flush the Char buffer if it is non-empty, then we
730 -- can work directly with the byte buffer
731 cbuf <- readIORef haCharBuffer
732 when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
734 r <- bufWrite h_ (castPtr ptr) count can_block
736 -- we must flush if this Handle is set to NoBuffering. If
737 -- it is set to LineBuffering, be conservative and flush
738 -- anyway (we didn't check for newlines in the data).
740 BlockBuffering _ -> do return ()
741 _line_or_no_buffering -> do flushWriteBuffer h_
744 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
745 bufWrite h_@Handle__{..} ptr count can_block =
746 seq count $ do -- strictness hack
747 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
748 <- readIORef haByteBuffer
750 -- enough room in handle buffer?
751 if (size - w > count)
752 -- There's enough room in the buffer:
753 -- just copy the data in and update bufR.
754 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
755 copyToRawBuffer old_raw w ptr (fromIntegral count)
756 writeIORef haByteBuffer old_buf{ bufR = w + count }
759 -- else, we have to flush
760 else do debugIO "hPutBuf: flushing first"
761 old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
762 -- TODO: we should do a non-blocking flush here
763 writeIORef haByteBuffer old_buf'
764 -- if we can fit in the buffer, then just loop
766 then bufWrite h_ ptr count can_block
768 then do writeChunk h_ (castPtr ptr) count
770 else writeChunkNonBlocking h_ (castPtr ptr) count
772 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
773 writeChunk h_@Handle__{..} ptr bytes
774 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
775 | otherwise = error "Todo: hPutBuf"
777 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
778 writeChunkNonBlocking h_@Handle__{..} ptr bytes
779 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
780 | otherwise = error "Todo: hPutBuf"
782 -- ---------------------------------------------------------------------------
785 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
786 -- into the buffer @buf@ until either EOF is reached or
787 -- @count@ 8-bit bytes have been read.
788 -- It returns the number of bytes actually read. This may be zero if
789 -- EOF was reached before any data was read (or if @count@ is zero).
791 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
792 -- using, and reads bytes directly from the underlying IO device.
794 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
795 -- smaller than @count@.
797 -- If the handle is a pipe or socket, and the writing end
798 -- is closed, 'hGetBuf' will behave as if EOF was reached.
800 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
801 -- on the 'Handle', and reads bytes directly.
803 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
805 | count == 0 = return 0
806 | count < 0 = illegalBufferSize h "hGetBuf" count
808 wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
809 flushCharReadBuffer h_
810 bufRead h_ (castPtr ptr) 0 count
812 -- small reads go through the buffer, large reads are satisfied by
813 -- taking data first from the buffer and then direct from the file
815 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
816 bufRead h_@Handle__{..} ptr so_far count =
817 seq so_far $ seq count $ do -- strictness hack
818 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
820 then if count > sz -- small read?
821 then do rest <- readChunk h_ ptr count
822 return (so_far + rest)
823 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
826 else do writeIORef haByteBuffer buf'
827 bufRead h_ ptr so_far count
832 copyFromRawBuffer ptr raw r count
833 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
834 return (so_far + count)
838 copyFromRawBuffer ptr raw r count
839 writeIORef haByteBuffer buf{ bufL = r + count }
840 return (so_far + count)
843 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
844 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
845 let remaining = count - avail
846 so_far' = so_far + avail
847 ptr' = ptr `plusPtr` avail
850 then bufRead h_ ptr' so_far' remaining
853 rest <- readChunk h_ ptr' remaining
854 return (so_far' + rest)
856 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
857 readChunk h_@Handle__{..} ptr bytes
858 | Just fd <- cast haDevice = loop fd 0 bytes
859 | otherwise = error "ToDo: hGetBuf"
861 loop :: FD -> Int -> Int -> IO Int
862 loop fd off bytes | bytes <= 0 = return off
863 loop fd off bytes = do
864 r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
867 else loop fd (off + r) (bytes - r)
869 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
870 -- into the buffer @buf@ until either EOF is reached, or
871 -- @count@ 8-bit bytes have been read, or there is no more data available
872 -- to read immediately.
874 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
875 -- never block waiting for data to become available, instead it returns
876 -- only whatever data is available. To wait for data to arrive before
877 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
879 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
880 -- is currently using, and reads bytes directly from the underlying IO
883 -- If the handle is a pipe or socket, and the writing end
884 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
886 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
887 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
889 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
890 hGetBufNonBlocking h ptr count
891 | count == 0 = return 0
892 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
894 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
895 flushCharReadBuffer h_
896 bufReadNonBlocking h_ (castPtr ptr) 0 count
898 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
899 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
900 seq so_far $ seq count $ do -- strictness hack
901 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
903 then if count > sz -- large read?
904 then do rest <- readChunkNonBlocking h_ ptr count
905 return (so_far + rest)
906 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
908 Nothing -> return so_far
909 Just 0 -> return so_far
911 writeIORef haByteBuffer buf'
912 bufReadNonBlocking h_ ptr so_far (min count r)
913 -- NOTE: new count is min count w'
914 -- so we will just copy the contents of the
915 -- buffer in the recursive call, and not
921 copyFromRawBuffer ptr raw r count
922 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
923 return (so_far + count)
927 copyFromRawBuffer ptr raw r count
928 writeIORef haByteBuffer buf{ bufL = r + count }
929 return (so_far + count)
932 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
933 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
934 let remaining = count - avail
935 so_far' = so_far + avail
936 ptr' = ptr `plusPtr` avail
938 -- we haven't attempted to read anything yet if we get to here.
940 then bufReadNonBlocking h_ ptr' so_far' remaining
943 rest <- readChunkNonBlocking h_ ptr' remaining
944 return (so_far' + rest)
947 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
948 readChunkNonBlocking h_@Handle__{..} ptr bytes
949 | Just fd <- cast haDevice = do
950 m <- RawIO.readNonBlocking (fd::FD) ptr bytes
954 | otherwise = error "ToDo: hGetBuf"
956 -- ---------------------------------------------------------------------------
959 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
960 copyToRawBuffer raw off ptr bytes =
961 withRawBuffer raw $ \praw ->
962 do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
965 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
966 copyFromRawBuffer ptr raw off bytes =
967 withRawBuffer raw $ \praw ->
968 do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
971 foreign import ccall unsafe "memcpy"
972 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
974 -----------------------------------------------------------------------------
977 illegalBufferSize :: Handle -> String -> Int -> IO a
978 illegalBufferSize handle fn sz =
979 ioException (IOError (Just handle)
981 ("illegal buffer size " ++ showsPrec 9 sz [])