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 buf <- readIORef haCharBuffer
83 if not (isEmptyBuffer buf)
88 then do buf' <- readTextDevice handle_ buf
89 writeIORef haCharBuffer buf'
91 else do r <- IODevice.ready haDevice False{-read-} msecs
92 if r then do -- Call hLookAhead' to throw an EOF
93 -- exception if appropriate
98 -- ---------------------------------------------------------------------------
101 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
102 -- channel managed by @hdl@, blocking until a character is available.
104 -- This operation may fail with:
106 -- * 'isEOFError' if the end of file has been reached.
108 hGetChar :: Handle -> IO Char
110 wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
112 -- buffering mode makes no difference: we just read whatever is available
113 -- from the device (blocking only if there is nothing available), and then
114 -- return the first character.
115 -- See [note Buffered Reading] in GHC.IO.Handle.Types
116 buf0 <- readIORef haCharBuffer
118 buf1 <- if isEmptyBuffer buf0
119 then readTextDevice handle_ buf0
122 (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
123 let buf2 = bufferAdjustL i buf1
125 if haInputNL == CRLF && c1 == '\r'
127 mbuf3 <- if isEmptyBuffer buf2
128 then maybeFillReadBuffer handle_ buf2
129 else return (Just buf2)
132 -- EOF, so just return the '\r' we have
134 writeIORef haCharBuffer buf2
137 (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
140 writeIORef haCharBuffer (bufferAdjustL i2 buf3)
143 -- not a \r\n sequence, so just return the \r
144 writeIORef haCharBuffer buf3
147 writeIORef haCharBuffer buf2
150 -- ---------------------------------------------------------------------------
153 -- ToDo: the unbuffered case is wrong: it doesn't lock the handle for
156 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
157 -- channel managed by @hdl@.
159 -- This operation may fail with:
161 -- * 'isEOFError' if the end of file is encountered when reading
162 -- the /first/ character of the line.
164 -- If 'hGetLine' encounters end-of-file at any other point while reading
165 -- in a line, it is treated as a line terminator and the (partial)
168 hGetLine :: Handle -> IO String
170 wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
171 hGetLineBuffered handle_
173 hGetLineBuffered :: Handle__ -> IO String
174 hGetLineBuffered handle_@Handle__{..} = do
175 buf <- readIORef haCharBuffer
176 hGetLineBufferedLoop handle_ buf []
178 hGetLineBufferedLoop :: Handle__
179 -> CharBuffer -> [String]
181 hGetLineBufferedLoop handle_@Handle__{..}
182 buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
184 -- find the end-of-line character, if there is one
186 | r == w = return (False, w)
188 (c,r') <- readCharBuf raw r
190 then return (True, r) -- NB. not r': don't include the '\n'
193 (eol, off) <- loop raw0 r0
195 debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
197 (xs,r') <- if haInputNL == CRLF
198 then unpack_nl raw0 r0 off ""
199 else do xs <- unpack raw0 r0 off ""
202 -- if eol == True, then off is the offset of the '\n'
203 -- otherwise off == w and the buffer is now empty.
205 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
206 return (concat (reverse (xs:xss)))
208 let buf1 = bufferAdjustL r' buf
209 maybe_buf <- maybeFillReadBuffer handle_ buf1
211 -- Nothing indicates we caught an EOF, and we may have a
212 -- partial line to return.
214 -- we reached EOF. There might be a lone \r left
215 -- in the buffer, so check for that and
216 -- append it to the line if necessary.
218 let pre = if not (isEmptyBuffer buf1) then "\r" else ""
219 writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
220 let str = concat (reverse (pre:xs:xss))
225 hGetLineBufferedLoop handle_ new_buf (xs:xss)
227 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
228 maybeFillReadBuffer handle_ buf
230 (do buf' <- getSomeCharacters handle_ buf
233 (\e -> do if isEOFError e
238 #define CHARBUF_UTF32
239 -- #define CHARBUF_UTF16
241 -- NB. performance-critical code: eyeball the Core.
242 unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
243 unpack !buf !r !w acc0
244 | r == w = return acc0
246 withRawBuffer buf $ \pbuf ->
252 -- reverse-order decoding of UTF-16
253 c2 <- peekElemOff pbuf i
254 if (c2 < 0xdc00 || c2 > 0xdffff)
255 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
256 else do c1 <- peekElemOff pbuf (i-1)
257 let c = (fromIntegral c1 - 0xd800) * 0x400 +
258 (fromIntegral c2 - 0xdc00) + 0x10000
259 unpackRB (unsafeChr c : acc) (i-2)
261 c <- peekElemOff pbuf i
262 unpackRB (c:acc) (i-1)
267 -- NB. performance-critical code: eyeball the Core.
268 unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
269 unpack_nl !buf !r !w acc0
270 | r == w = return (acc0, 0)
272 withRawBuffer buf $ \pbuf ->
277 c <- peekElemOff pbuf i
278 if (c == '\n' && i > r)
280 c1 <- peekElemOff pbuf (i-1)
282 then unpackRB ('\n':acc) (i-2)
283 else unpackRB ('\n':acc) (i-1)
285 unpackRB (c:acc) (i-1)
287 c <- peekElemOff pbuf (w-1)
290 -- If the last char is a '\r', we need to know whether or
291 -- not it is followed by a '\n', so leave it in the buffer
292 -- for now and just unpack the rest.
293 str <- unpackRB acc0 (w-2)
296 str <- unpackRB acc0 (w-1)
300 -- -----------------------------------------------------------------------------
303 -- hGetContents on a DuplexHandle only affects the read side: you can
304 -- carry on writing to it afterwards.
306 -- | Computation 'hGetContents' @hdl@ returns the list of characters
307 -- corresponding to the unread portion of the channel or file managed
308 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
309 -- In this state, @hdl@ is effectively closed,
310 -- but items are read from @hdl@ on demand and accumulated in a special
311 -- list returned by 'hGetContents' @hdl@.
313 -- Any operation that fails because a handle is closed,
314 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
315 -- A semi-closed handle becomes closed:
317 -- * if 'hClose' is applied to it;
319 -- * if an I\/O error occurs when reading an item from the handle;
321 -- * or once the entire contents of the handle has been read.
323 -- Once a semi-closed handle becomes closed, the contents of the
324 -- associated list becomes fixed. The contents of this final list is
325 -- only partially specified: it will contain at least all the items of
326 -- the stream that were evaluated prior to the handle becoming closed.
328 -- Any I\/O errors encountered while a handle is semi-closed are simply
331 -- This operation may fail with:
333 -- * 'isEOFError' if the end of file has been reached.
335 hGetContents :: Handle -> IO String
336 hGetContents handle =
337 wantReadableHandle "hGetContents" handle $ \handle_ -> do
338 xs <- lazyRead handle
339 return (handle_{ haType=SemiClosedHandle}, xs )
341 -- Note that someone may close the semi-closed handle (or change its
342 -- buffering), so each time these lazy read functions are pulled on,
343 -- they have to check whether the handle has indeed been closed.
345 lazyRead :: Handle -> IO String
348 withHandle "lazyRead" handle $ \ handle_ -> do
349 case haType handle_ of
350 ClosedHandle -> return (handle_, "")
351 SemiClosedHandle -> lazyReadBuffered handle handle_
353 (IOError (Just handle) IllegalOperation "lazyRead"
354 "illegal handle type" Nothing Nothing)
356 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
357 lazyReadBuffered h handle_@Handle__{..} = do
358 buf <- readIORef haCharBuffer
361 buf'@Buffer{..} <- getSomeCharacters handle_ buf
362 lazy_rest <- lazyRead h
363 (s,r) <- if haInputNL == CRLF
364 then unpack_nl bufRaw bufL bufR lazy_rest
365 else do s <- unpack bufRaw bufL bufR lazy_rest
367 writeIORef haCharBuffer (bufferAdjustL r buf')
370 -- all I/O errors are discarded. Additionally, we close the handle.
371 (\e -> do (handle_', _) <- hClose_help handle_
372 debugIO ("hGetContents caught: " ++ show e)
373 -- We might have a \r cached in CRLF mode. So we
374 -- need to check for that and return it:
375 if not (isEmptyBuffer buf)
376 then return (handle_', "\r")
377 else return (handle_', "")
380 -- ensure we have some characters in the buffer
381 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
382 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
383 case bufferElems buf of
385 -- buffer empty: read some more
386 0 -> readTextDevice handle_ buf
388 -- if the buffer has a single '\r' in it and we're doing newline
389 -- translation: read some more
390 1 | haInputNL == CRLF -> do
391 (c,_) <- readCharBuf bufRaw bufL
393 then do -- shuffle the '\r' to the beginning. This is only safe
394 -- if we're about to call readTextDevice, otherwise it
395 -- would mess up flushCharBuffer.
396 -- See [note Buffer Flushing], GHC.IO.Handle.Types
397 writeCharBuf bufRaw 0 '\r'
398 let buf' = buf{ bufL=0, bufR=1 }
399 readTextDevice handle_ buf'
403 -- buffer has some chars in it already: just return it
407 -- ---------------------------------------------------------------------------
410 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
411 -- file or channel managed by @hdl@. Characters may be buffered if
412 -- buffering is enabled for @hdl@.
414 -- This operation may fail with:
416 -- * 'isFullError' if the device is full; or
418 -- * 'isPermissionError' if another system resource limit would be exceeded.
420 hPutChar :: Handle -> Char -> IO ()
421 hPutChar handle c = do
423 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
424 case haBufferMode handle_ of
425 LineBuffering -> hPutcBuffered handle_ True c
426 _other -> hPutcBuffered handle_ False c
428 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
429 hPutcBuffered handle_@Handle__{..} is_line c = do
430 buf <- readIORef haCharBuffer
432 then do buf1 <- if haOutputNL == CRLF
434 buf1 <- putc buf '\r'
440 flushed_buf <- flushWriteBuffer_ handle_ buf1
441 writeIORef haCharBuffer flushed_buf
443 writeIORef haCharBuffer buf1
446 writeIORef haCharBuffer buf1
448 putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
449 debugIO ("putc: " ++ summaryBuffer buf)
450 w' <- writeCharBuf raw w c
451 let buf' = buf{ bufR = w' }
452 if isFullCharBuffer buf'
453 then flushWriteBuffer_ handle_ buf'
456 -- ---------------------------------------------------------------------------
459 -- We go to some trouble to avoid keeping the handle locked while we're
460 -- evaluating the string argument to hPutStr, in case doing so triggers another
461 -- I/O operation on the same handle which would lead to deadlock. The classic
464 -- putStr (trace "hello" "world")
466 -- so the basic scheme is this:
468 -- * copy the string into a fresh buffer,
469 -- * "commit" the buffer to the handle.
471 -- Committing may involve simply copying the contents of the new
472 -- buffer into the handle's buffer, flushing one or both buffers, or
473 -- maybe just swapping the buffers over (if the handle's buffer was
474 -- empty). See commitBuffer below.
476 -- | Computation 'hPutStr' @hdl s@ writes the string
477 -- @s@ to the file or channel managed by @hdl@.
479 -- This operation may fail with:
481 -- * 'isFullError' if the device is full; or
483 -- * 'isPermissionError' if another system resource limit would be exceeded.
485 hPutStr :: Handle -> String -> IO ()
486 hPutStr handle str = do
488 wantWritableHandle "hPutStr" handle $ \h_ -> do
489 bmode <- getSpareBuffer h_
490 return (bmode, haOutputNL h_)
493 (NoBuffering, _) -> do
494 hPutChars handle str -- v. slow, but we don't care
495 (LineBuffering, buf) -> do
496 writeBlocks handle True nl buf str
497 (BlockBuffering _, buf) -> do
498 writeBlocks handle False nl buf str
500 hPutChars :: Handle -> [Char] -> IO ()
501 hPutChars _ [] = return ()
502 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
504 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
505 getSpareBuffer Handle__{haCharBuffer=ref,
510 NoBuffering -> return (mode, error "no buffer!")
512 bufs <- readIORef spare_ref
515 BufferListCons b rest -> do
516 writeIORef spare_ref rest
517 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
519 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
520 return (mode, new_buf)
523 -- NB. performance-critical code: eyeball the Core.
524 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
525 writeBlocks hdl line_buffered nl
526 buf@Buffer{ bufRaw=raw, bufSize=len } s =
528 shoveString :: Int -> [Char] -> IO ()
529 shoveString !n [] = do
530 commitBuffer hdl raw len n False{-no flush-} True{-release-}
532 shoveString !n (c:cs)
533 -- n+1 so we have enough room to write '\r\n' if necessary
535 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
536 writeBlocks hdl line_buffered nl new_buf (c:cs)
540 n1 <- writeCharBuf raw n '\r'
541 writeCharBuf raw n1 '\n'
546 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
547 writeBlocks hdl line_buffered nl new_buf cs
551 n' <- writeCharBuf raw n c
556 -- -----------------------------------------------------------------------------
557 -- commitBuffer handle buf sz count flush release
559 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
560 -- 'count' bytes of data) to handle (handle must be block or line buffered).
564 -- for block/line buffering,
565 -- 1. If there isn't room in the handle buffer, flush the handle
568 -- 2. If the handle buffer is empty,
570 -- then write buf directly to the device.
571 -- else swap the handle buffer with buf.
573 -- 3. If the handle buffer is non-empty, copy buf into the
574 -- handle buffer. Then, if flush != 0, flush
578 :: Handle -- handle to commit to
579 -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
580 -> Int -- number of bytes of data in buffer
581 -> Bool -- True <=> flush the handle afterward
582 -> Bool -- release the buffer?
585 commitBuffer hdl !raw !sz !count flush release =
586 wantWritableHandle "commitAndReleaseBuffer" hdl $
587 commitBuffer' raw sz count flush release
588 {-# NOINLINE commitBuffer #-}
590 -- Explicitly lambda-lift this function to subvert GHC's full laziness
591 -- optimisations, which otherwise tends to float out subexpressions
592 -- past the \handle, which is really a pessimisation in this case because
593 -- that lambda is a one-shot lambda.
595 -- Don't forget to export the function, to stop it being inlined too
596 -- (this appears to be better than NOINLINE, because the strictness
597 -- analyser still gets to worker-wrapper it).
599 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
601 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
603 commitBuffer' raw sz@(I# _) count@(I# _) flush release
604 handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
606 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
607 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
609 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
613 -- enough room in handle buffer?
614 if (not flush && (size - w > count))
615 -- The > is to be sure that we never exactly fill
616 -- up the buffer, which would require a flush. So
617 -- if copying the new data into the buffer would
618 -- make the buffer full, we just flush the existing
619 -- buffer and the new data immediately, rather than
620 -- copying before flushing.
622 -- not flushing, and there's enough room in the buffer:
623 -- just copy the data in and update bufR.
624 then do withRawBuffer raw $ \praw ->
625 copyToRawBuffer old_raw (w*charSize)
626 praw (fromIntegral (count*charSize))
627 writeIORef ref old_buf{ bufR = w + count }
628 return (emptyBuffer raw sz WriteBuffer)
630 -- else, we have to flush
631 else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
634 Buffer{ bufRaw=raw, bufState=WriteBuffer,
635 bufL=0, bufR=count, bufSize=sz }
637 -- if: (a) we don't have to flush, and
638 -- (b) size(new buffer) == size(old buffer), and
639 -- (c) new buffer is not full,
640 -- we can just just swap them over...
641 if (not flush && sz == size && count /= sz)
643 writeIORef ref this_buf
646 -- otherwise, we have to flush the new data too,
647 -- and start with a fresh buffer
649 flushWriteBuffer_ handle_ this_buf
650 writeIORef ref flushed_buf
651 -- if the sizes were different, then allocate
652 -- a new buffer of the correct size.
654 then return (emptyBuffer raw sz WriteBuffer)
655 else newCharBuffer size WriteBuffer
657 -- release the buffer if necessary
659 Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
660 if release && buf_ret_sz == size
662 spare_bufs <- readIORef spare_buf_ref
663 writeIORef spare_buf_ref
664 (BufferListCons buf_ret_raw spare_bufs)
669 -- ---------------------------------------------------------------------------
670 -- Reading/writing sequences of bytes.
672 -- ---------------------------------------------------------------------------
675 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
676 -- buffer @buf@ to the handle @hdl@. It returns ().
678 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
679 -- writing the bytes directly to the underlying file or device.
681 -- This operation may fail with:
683 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
684 -- reading end is closed. (If this is a POSIX system, and the program
685 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
686 -- instead, whose default action is to terminate the program).
688 hPutBuf :: Handle -- handle to write to
689 -> Ptr a -- address of buffer
690 -> Int -- number of bytes of data in buffer
692 hPutBuf h ptr count = do hPutBuf' h ptr count True; return ()
695 :: Handle -- handle to write to
696 -> Ptr a -- address of buffer
697 -> Int -- number of bytes of data in buffer
698 -> IO Int -- returns: number of bytes written
699 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
701 hPutBuf':: Handle -- handle to write to
702 -> Ptr a -- address of buffer
703 -> Int -- number of bytes of data in buffer
704 -> Bool -- allow blocking?
706 hPutBuf' handle ptr count can_block
707 | count == 0 = return 0
708 | count < 0 = illegalBufferSize handle "hPutBuf" count
710 wantWritableHandle "hPutBuf" handle $
711 \ h_@Handle__{..} -> do
712 debugIO ("hPutBuf count=" ++ show count)
713 -- first flush the Char buffer if it is non-empty, then we
714 -- can work directly with the byte buffer
715 cbuf <- readIORef haCharBuffer
716 when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
718 r <- bufWrite h_ (castPtr ptr) count can_block
720 -- we must flush if this Handle is set to NoBuffering. If
721 -- it is set to LineBuffering, be conservative and flush
722 -- anyway (we didn't check for newlines in the data).
724 BlockBuffering _ -> do return ()
725 _line_or_no_buffering -> do flushWriteBuffer h_
728 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
729 bufWrite h_@Handle__{..} ptr count can_block =
730 seq count $ do -- strictness hack
731 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
732 <- readIORef haByteBuffer
734 -- enough room in handle buffer?
735 if (size - w > count)
736 -- There's enough room in the buffer:
737 -- just copy the data in and update bufR.
738 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
739 copyToRawBuffer old_raw w ptr (fromIntegral count)
740 writeIORef haByteBuffer old_buf{ bufR = w + count }
743 -- else, we have to flush
744 else do debugIO "hPutBuf: flushing first"
745 Buffered.flushWriteBuffer haDevice old_buf
746 -- TODO: we should do a non-blocking flush here
747 writeIORef haByteBuffer old_buf{bufL=0,bufR=0}
748 -- if we can fit in the buffer, then just loop
750 then bufWrite h_ ptr count can_block
752 then do writeChunk h_ (castPtr ptr) count
754 else writeChunkNonBlocking h_ (castPtr ptr) count
756 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
757 writeChunk h_@Handle__{..} ptr bytes
758 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
759 | otherwise = error "Todo: hPutBuf"
761 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
762 writeChunkNonBlocking h_@Handle__{..} ptr bytes
763 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
764 | otherwise = error "Todo: hPutBuf"
766 -- ---------------------------------------------------------------------------
769 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
770 -- into the buffer @buf@ until either EOF is reached or
771 -- @count@ 8-bit bytes have been read.
772 -- It returns the number of bytes actually read. This may be zero if
773 -- EOF was reached before any data was read (or if @count@ is zero).
775 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
776 -- using, and reads bytes directly from the underlying IO device.
778 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
779 -- smaller than @count@.
781 -- If the handle is a pipe or socket, and the writing end
782 -- is closed, 'hGetBuf' will behave as if EOF was reached.
785 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
787 | count == 0 = return 0
788 | count < 0 = illegalBufferSize h "hGetBuf" count
790 wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
791 flushCharReadBuffer h_
792 bufRead h_ (castPtr ptr) 0 count
794 -- small reads go through the buffer, large reads are satisfied by
795 -- taking data first from the buffer and then direct from the file
797 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
798 bufRead h_@Handle__{..} ptr so_far count =
799 seq so_far $ seq count $ do -- strictness hack
800 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
802 then if count > sz -- small read?
803 then do rest <- readChunk h_ ptr count
804 return (so_far + rest)
805 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
808 else do writeIORef haByteBuffer buf'
809 bufRead h_ ptr so_far count
814 copyFromRawBuffer ptr raw r count
815 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
816 return (so_far + count)
820 copyFromRawBuffer ptr raw r count
821 writeIORef haByteBuffer buf{ bufL = r + count }
822 return (so_far + count)
825 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
826 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
827 let remaining = count - avail
828 so_far' = so_far + avail
829 ptr' = ptr `plusPtr` avail
832 then bufRead h_ ptr' so_far' remaining
835 rest <- readChunk h_ ptr' remaining
836 return (so_far' + rest)
838 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
839 readChunk h_@Handle__{..} ptr bytes
840 | Just fd <- cast haDevice = loop fd 0 bytes
841 | otherwise = error "ToDo: hGetBuf"
843 loop :: FD -> Int -> Int -> IO Int
844 loop fd off bytes | bytes <= 0 = return off
845 loop fd off bytes = do
846 r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
849 else loop fd (off + r) (bytes - r)
851 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
852 -- into the buffer @buf@ until either EOF is reached, or
853 -- @count@ 8-bit bytes have been read, or there is no more data available
854 -- to read immediately.
856 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
857 -- never block waiting for data to become available, instead it returns
858 -- only whatever data is available. To wait for data to arrive before
859 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
861 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
862 -- is currently using, and reads bytes directly from the underlying IO
865 -- If the handle is a pipe or socket, and the writing end
866 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
868 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
869 hGetBufNonBlocking h ptr count
870 | count == 0 = return 0
871 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
873 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
874 flushCharReadBuffer h_
875 bufReadNonBlocking h_ (castPtr ptr) 0 count
877 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
878 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
879 seq so_far $ seq count $ do -- strictness hack
880 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
882 then if count > sz -- large read?
883 then do rest <- readChunkNonBlocking h_ ptr count
884 return (so_far + rest)
885 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
887 Nothing -> return so_far
888 Just 0 -> return so_far
890 writeIORef haByteBuffer buf'
891 bufReadNonBlocking h_ ptr so_far (min count r)
892 -- NOTE: new count is min count w'
893 -- so we will just copy the contents of the
894 -- buffer in the recursive call, and not
900 copyFromRawBuffer ptr raw r count
901 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
902 return (so_far + count)
906 copyFromRawBuffer ptr raw r count
907 writeIORef haByteBuffer buf{ bufL = r + count }
908 return (so_far + count)
911 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
912 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
913 let remaining = count - avail
914 so_far' = so_far + avail
915 ptr' = ptr `plusPtr` avail
917 -- we haven't attempted to read anything yet if we get to here.
919 then bufReadNonBlocking h_ ptr' so_far' remaining
922 rest <- readChunkNonBlocking h_ ptr' remaining
923 return (so_far' + rest)
926 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
927 readChunkNonBlocking h_@Handle__{..} ptr bytes
928 | Just fd <- cast haDevice = do
929 m <- RawIO.readNonBlocking (fd::FD) ptr bytes
933 | otherwise = error "ToDo: hGetBuf"
935 -- ---------------------------------------------------------------------------
938 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
939 copyToRawBuffer raw off ptr bytes = do
940 withRawBuffer raw $ \praw ->
941 memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
944 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
945 copyFromRawBuffer ptr raw off bytes = do
946 withRawBuffer raw $ \praw ->
947 memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
950 foreign import ccall unsafe "memcpy"
951 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
953 -----------------------------------------------------------------------------
956 illegalBufferSize :: Handle -> String -> Int -> IO a
957 illegalBufferSize handle fn sz =
958 ioException (IOError (Just handle)
960 ("illegal buffer size " ++ showsPrec 9 sz [])