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
94 _ <- hLookAhead_ handle_
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 -- We're aren't going to use this buffer again
650 -- so we ignore the result of flushWriteBuffer_
651 _ <- flushWriteBuffer_ handle_ this_buf
652 writeIORef ref flushed_buf
653 -- if the sizes were different, then allocate
654 -- a new buffer of the correct size.
656 then return (emptyBuffer raw sz WriteBuffer)
657 else newCharBuffer size WriteBuffer
659 -- release the buffer if necessary
661 Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
662 if release && buf_ret_sz == size
664 spare_bufs <- readIORef spare_buf_ref
665 writeIORef spare_buf_ref
666 (BufferListCons buf_ret_raw spare_bufs)
671 -- ---------------------------------------------------------------------------
672 -- Reading/writing sequences of bytes.
674 -- ---------------------------------------------------------------------------
677 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
678 -- buffer @buf@ to the handle @hdl@. It returns ().
680 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
681 -- writing the bytes directly to the underlying file or device.
683 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
684 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
686 -- This operation may fail with:
688 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
689 -- reading end is closed. (If this is a POSIX system, and the program
690 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
691 -- instead, whose default action is to terminate the program).
693 hPutBuf :: Handle -- handle to write to
694 -> Ptr a -- address of buffer
695 -> Int -- number of bytes of data in buffer
697 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
701 :: Handle -- handle to write to
702 -> Ptr a -- address of buffer
703 -> Int -- number of bytes of data in buffer
704 -> IO Int -- returns: number of bytes written
705 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
707 hPutBuf':: Handle -- handle to write to
708 -> Ptr a -- address of buffer
709 -> Int -- number of bytes of data in buffer
710 -> Bool -- allow blocking?
712 hPutBuf' handle ptr count can_block
713 | count == 0 = return 0
714 | count < 0 = illegalBufferSize handle "hPutBuf" count
716 wantWritableHandle "hPutBuf" handle $
717 \ h_@Handle__{..} -> do
718 debugIO ("hPutBuf count=" ++ show count)
719 -- first flush the Char buffer if it is non-empty, then we
720 -- can work directly with the byte buffer
721 cbuf <- readIORef haCharBuffer
722 when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
724 r <- bufWrite h_ (castPtr ptr) count can_block
726 -- we must flush if this Handle is set to NoBuffering. If
727 -- it is set to LineBuffering, be conservative and flush
728 -- anyway (we didn't check for newlines in the data).
730 BlockBuffering _ -> do return ()
731 _line_or_no_buffering -> do flushWriteBuffer h_
734 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
735 bufWrite h_@Handle__{..} ptr count can_block =
736 seq count $ do -- strictness hack
737 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
738 <- readIORef haByteBuffer
740 -- enough room in handle buffer?
741 if (size - w > count)
742 -- There's enough room in the buffer:
743 -- just copy the data in and update bufR.
744 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
745 copyToRawBuffer old_raw w ptr (fromIntegral count)
746 writeIORef haByteBuffer old_buf{ bufR = w + count }
749 -- else, we have to flush
750 else do debugIO "hPutBuf: flushing first"
751 Buffered.flushWriteBuffer haDevice old_buf
752 -- TODO: we should do a non-blocking flush here
753 writeIORef haByteBuffer old_buf{bufL=0,bufR=0}
754 -- if we can fit in the buffer, then just loop
756 then bufWrite h_ ptr count can_block
758 then do writeChunk h_ (castPtr ptr) count
760 else writeChunkNonBlocking h_ (castPtr ptr) count
762 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
763 writeChunk h_@Handle__{..} ptr bytes
764 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
765 | otherwise = error "Todo: hPutBuf"
767 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
768 writeChunkNonBlocking h_@Handle__{..} ptr bytes
769 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
770 | otherwise = error "Todo: hPutBuf"
772 -- ---------------------------------------------------------------------------
775 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
776 -- into the buffer @buf@ until either EOF is reached or
777 -- @count@ 8-bit bytes have been read.
778 -- It returns the number of bytes actually read. This may be zero if
779 -- EOF was reached before any data was read (or if @count@ is zero).
781 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
782 -- using, and reads bytes directly from the underlying IO device.
784 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
785 -- smaller than @count@.
787 -- If the handle is a pipe or socket, and the writing end
788 -- is closed, 'hGetBuf' will behave as if EOF was reached.
790 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
791 -- on the 'Handle', and reads bytes directly.
793 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
795 | count == 0 = return 0
796 | count < 0 = illegalBufferSize h "hGetBuf" count
798 wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
799 flushCharReadBuffer h_
800 bufRead h_ (castPtr ptr) 0 count
802 -- small reads go through the buffer, large reads are satisfied by
803 -- taking data first from the buffer and then direct from the file
805 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
806 bufRead h_@Handle__{..} ptr so_far count =
807 seq so_far $ seq count $ do -- strictness hack
808 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
810 then if count > sz -- small read?
811 then do rest <- readChunk h_ ptr count
812 return (so_far + rest)
813 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
816 else do writeIORef haByteBuffer buf'
817 bufRead h_ ptr so_far count
822 copyFromRawBuffer ptr raw r count
823 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
824 return (so_far + count)
828 copyFromRawBuffer ptr raw r count
829 writeIORef haByteBuffer buf{ bufL = r + count }
830 return (so_far + count)
833 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
834 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
835 let remaining = count - avail
836 so_far' = so_far + avail
837 ptr' = ptr `plusPtr` avail
840 then bufRead h_ ptr' so_far' remaining
843 rest <- readChunk h_ ptr' remaining
844 return (so_far' + rest)
846 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
847 readChunk h_@Handle__{..} ptr bytes
848 | Just fd <- cast haDevice = loop fd 0 bytes
849 | otherwise = error "ToDo: hGetBuf"
851 loop :: FD -> Int -> Int -> IO Int
852 loop fd off bytes | bytes <= 0 = return off
853 loop fd off bytes = do
854 r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
857 else loop fd (off + r) (bytes - r)
859 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
860 -- into the buffer @buf@ until either EOF is reached, or
861 -- @count@ 8-bit bytes have been read, or there is no more data available
862 -- to read immediately.
864 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
865 -- never block waiting for data to become available, instead it returns
866 -- only whatever data is available. To wait for data to arrive before
867 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
869 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
870 -- is currently using, and reads bytes directly from the underlying IO
873 -- If the handle is a pipe or socket, and the writing end
874 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
876 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
877 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
879 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
880 hGetBufNonBlocking h ptr count
881 | count == 0 = return 0
882 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
884 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
885 flushCharReadBuffer h_
886 bufReadNonBlocking h_ (castPtr ptr) 0 count
888 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
889 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
890 seq so_far $ seq count $ do -- strictness hack
891 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
893 then if count > sz -- large read?
894 then do rest <- readChunkNonBlocking h_ ptr count
895 return (so_far + rest)
896 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
898 Nothing -> return so_far
899 Just 0 -> return so_far
901 writeIORef haByteBuffer buf'
902 bufReadNonBlocking h_ ptr so_far (min count r)
903 -- NOTE: new count is min count w'
904 -- so we will just copy the contents of the
905 -- buffer in the recursive call, and not
911 copyFromRawBuffer ptr raw r count
912 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
913 return (so_far + count)
917 copyFromRawBuffer ptr raw r count
918 writeIORef haByteBuffer buf{ bufL = r + count }
919 return (so_far + count)
922 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
923 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
924 let remaining = count - avail
925 so_far' = so_far + avail
926 ptr' = ptr `plusPtr` avail
928 -- we haven't attempted to read anything yet if we get to here.
930 then bufReadNonBlocking h_ ptr' so_far' remaining
933 rest <- readChunkNonBlocking h_ ptr' remaining
934 return (so_far' + rest)
937 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
938 readChunkNonBlocking h_@Handle__{..} ptr bytes
939 | Just fd <- cast haDevice = do
940 m <- RawIO.readNonBlocking (fd::FD) ptr bytes
944 | otherwise = error "ToDo: hGetBuf"
946 -- ---------------------------------------------------------------------------
949 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
950 copyToRawBuffer raw off ptr bytes =
951 withRawBuffer raw $ \praw ->
952 do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
955 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
956 copyFromRawBuffer ptr raw off bytes =
957 withRawBuffer raw $ \praw ->
958 do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
961 foreign import ccall unsafe "memcpy"
962 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
964 -----------------------------------------------------------------------------
967 illegalBufferSize :: Handle -> String -> Int -> IO a
968 illegalBufferSize handle fn sz =
969 ioException (IOError (Just handle)
971 ("illegal buffer size " ++ showsPrec 9 sz [])