1 {-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
2 {-# OPTIONS_GHC -XRecordWildCards -XBangPatterns #-}
3 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
4 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
5 {-# OPTIONS_HADDOCK hide #-}
7 -----------------------------------------------------------------------------
9 -- Module : GHC.IO.Text
10 -- Copyright : (c) The University of Glasgow, 1992-2008
11 -- License : see libraries/base/LICENSE
13 -- Maintainer : libraries@haskell.org
14 -- Stability : internal
15 -- Portability : non-portable
17 -- String I\/O functions
19 -----------------------------------------------------------------------------
22 module GHC.IO.Handle.Text (
23 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
24 commitBuffer', -- hack, see below
25 hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
32 import qualified GHC.IO.BufferedIO as Buffered
33 import GHC.IO.Exception
35 import GHC.IO.Handle.Types
36 import GHC.IO.Handle.Internals
37 import qualified GHC.IO.Device as IODevice
38 import qualified GHC.IO.Device as RawIO
44 import System.IO.Error
55 -- ---------------------------------------------------------------------------
56 -- Simple input operations
58 -- If hWaitForInput finds anything in the Handle's buffer, it
59 -- immediately returns. If not, it tries to read from the underlying
60 -- OS handle. Notice that for buffered Handles connected to terminals
61 -- this means waiting until a complete line is available.
63 -- | Computation 'hWaitForInput' @hdl t@
64 -- waits until input is available on handle @hdl@.
65 -- It returns 'True' as soon as input is available on @hdl@,
66 -- or 'False' if no input is available within @t@ milliseconds. Note that
67 -- 'hWaitForInput' waits until one or more full /characters/ are available,
68 -- which means that it needs to do decoding, and hence may fail
69 -- with a decoding error.
71 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
73 -- This operation may fail with:
75 -- * 'isEOFError' if the end of file has been reached.
77 -- * a decoding error, if the input begins with an invalid byte sequence
78 -- in this Handle's encoding.
80 -- NOTE for GHC users: unless you use the @-threaded@ flag,
81 -- @hWaitForInput t@ where @t >= 0@ will block all other Haskell
82 -- threads for the duration of the call. It behaves like a
83 -- @safe@ foreign call in this respect.
86 hWaitForInput :: Handle -> Int -> IO Bool
87 hWaitForInput h msecs = do
88 wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
89 cbuf <- readIORef haCharBuffer
91 if not (isEmptyBuffer cbuf) then return True else do
94 then do cbuf' <- readTextDevice handle_ cbuf
95 writeIORef haCharBuffer cbuf'
98 -- there might be bytes in the byte buffer waiting to be decoded
99 cbuf' <- decodeByteBuf handle_ cbuf
100 writeIORef haCharBuffer cbuf'
102 if not (isEmptyBuffer cbuf') then return True else do
104 r <- IODevice.ready haDevice False{-read-} msecs
105 if r then do -- Call hLookAhead' to throw an EOF
106 -- exception if appropriate
107 _ <- hLookAhead_ handle_
110 -- XXX we should only return when there are full characters
111 -- not when there are only bytes. That would mean looping
112 -- and re-running IODevice.ready if we don't have any full
113 -- characters; but we don't know how long we've waited
116 -- ---------------------------------------------------------------------------
119 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
120 -- channel managed by @hdl@, blocking until a character is available.
122 -- This operation may fail with:
124 -- * 'isEOFError' if the end of file has been reached.
126 hGetChar :: Handle -> IO Char
128 wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
130 -- buffering mode makes no difference: we just read whatever is available
131 -- from the device (blocking only if there is nothing available), and then
132 -- return the first character.
133 -- See [note Buffered Reading] in GHC.IO.Handle.Types
134 buf0 <- readIORef haCharBuffer
136 buf1 <- if isEmptyBuffer buf0
137 then readTextDevice handle_ buf0
140 (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
141 let buf2 = bufferAdjustL i buf1
143 if haInputNL == CRLF && c1 == '\r'
145 mbuf3 <- if isEmptyBuffer buf2
146 then maybeFillReadBuffer handle_ buf2
147 else return (Just buf2)
150 -- EOF, so just return the '\r' we have
152 writeIORef haCharBuffer buf2
155 (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
158 writeIORef haCharBuffer (bufferAdjustL i2 buf3)
161 -- not a \r\n sequence, so just return the \r
162 writeIORef haCharBuffer buf3
165 writeIORef haCharBuffer buf2
168 -- ---------------------------------------------------------------------------
171 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
172 -- channel managed by @hdl@.
174 -- This operation may fail with:
176 -- * 'isEOFError' if the end of file is encountered when reading
177 -- the /first/ character of the line.
179 -- If 'hGetLine' encounters end-of-file at any other point while reading
180 -- in a line, it is treated as a line terminator and the (partial)
183 hGetLine :: Handle -> IO String
185 wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
186 hGetLineBuffered handle_
188 hGetLineBuffered :: Handle__ -> IO String
189 hGetLineBuffered handle_@Handle__{..} = do
190 buf <- readIORef haCharBuffer
191 hGetLineBufferedLoop handle_ buf []
193 hGetLineBufferedLoop :: Handle__
194 -> CharBuffer -> [String]
196 hGetLineBufferedLoop handle_@Handle__{..}
197 buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
199 -- find the end-of-line character, if there is one
201 | r == w = return (False, w)
203 (c,r') <- readCharBuf raw r
205 then return (True, r) -- NB. not r': don't include the '\n'
208 (eol, off) <- loop raw0 r0
210 debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
212 (xs,r') <- if haInputNL == CRLF
213 then unpack_nl raw0 r0 off ""
214 else do xs <- unpack raw0 r0 off ""
217 -- if eol == True, then off is the offset of the '\n'
218 -- otherwise off == w and the buffer is now empty.
220 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
221 return (concat (reverse (xs:xss)))
223 let buf1 = bufferAdjustL r' buf
224 maybe_buf <- maybeFillReadBuffer handle_ buf1
226 -- Nothing indicates we caught an EOF, and we may have a
227 -- partial line to return.
229 -- we reached EOF. There might be a lone \r left
230 -- in the buffer, so check for that and
231 -- append it to the line if necessary.
233 let pre = if not (isEmptyBuffer buf1) then "\r" else ""
234 writeIORef haCharBuffer buf1{ bufL=0, bufR=0 }
235 let str = concat (reverse (pre:xs:xss))
240 hGetLineBufferedLoop handle_ new_buf (xs:xss)
242 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
243 maybeFillReadBuffer handle_ buf
245 (do buf' <- getSomeCharacters handle_ buf
248 (\e -> do if isEOFError e
253 #define CHARBUF_UTF32
254 -- #define CHARBUF_UTF16
256 -- NB. performance-critical code: eyeball the Core.
257 unpack :: RawCharBuffer -> Int -> Int -> [Char] -> IO [Char]
258 unpack !buf !r !w acc0
259 | r == w = return acc0
261 withRawBuffer buf $ \pbuf ->
267 -- reverse-order decoding of UTF-16
268 c2 <- peekElemOff pbuf i
269 if (c2 < 0xdc00 || c2 > 0xdffff)
270 then unpackRB (unsafeChr (fromIntegral c2) : acc) (i-1)
271 else do c1 <- peekElemOff pbuf (i-1)
272 let c = (fromIntegral c1 - 0xd800) * 0x400 +
273 (fromIntegral c2 - 0xdc00) + 0x10000
274 unpackRB (unsafeChr c : acc) (i-2)
276 c <- peekElemOff pbuf i
277 unpackRB (c:acc) (i-1)
282 -- NB. performance-critical code: eyeball the Core.
283 unpack_nl :: RawCharBuffer -> Int -> Int -> [Char] -> IO ([Char],Int)
284 unpack_nl !buf !r !w acc0
285 | r == w = return (acc0, 0)
287 withRawBuffer buf $ \pbuf ->
292 c <- peekElemOff pbuf i
293 if (c == '\n' && i > r)
295 c1 <- peekElemOff pbuf (i-1)
297 then unpackRB ('\n':acc) (i-2)
298 else unpackRB ('\n':acc) (i-1)
300 unpackRB (c:acc) (i-1)
302 c <- peekElemOff pbuf (w-1)
305 -- If the last char is a '\r', we need to know whether or
306 -- not it is followed by a '\n', so leave it in the buffer
307 -- for now and just unpack the rest.
308 str <- unpackRB acc0 (w-2)
311 str <- unpackRB acc0 (w-1)
315 -- -----------------------------------------------------------------------------
318 -- hGetContents on a DuplexHandle only affects the read side: you can
319 -- carry on writing to it afterwards.
321 -- | Computation 'hGetContents' @hdl@ returns the list of characters
322 -- corresponding to the unread portion of the channel or file managed
323 -- by @hdl@, which is put into an intermediate state, /semi-closed/.
324 -- In this state, @hdl@ is effectively closed,
325 -- but items are read from @hdl@ on demand and accumulated in a special
326 -- list returned by 'hGetContents' @hdl@.
328 -- Any operation that fails because a handle is closed,
329 -- also fails if a handle is semi-closed. The only exception is 'hClose'.
330 -- A semi-closed handle becomes closed:
332 -- * if 'hClose' is applied to it;
334 -- * if an I\/O error occurs when reading an item from the handle;
336 -- * or once the entire contents of the handle has been read.
338 -- Once a semi-closed handle becomes closed, the contents of the
339 -- associated list becomes fixed. The contents of this final list is
340 -- only partially specified: it will contain at least all the items of
341 -- the stream that were evaluated prior to the handle becoming closed.
343 -- Any I\/O errors encountered while a handle is semi-closed are simply
346 -- This operation may fail with:
348 -- * 'isEOFError' if the end of file has been reached.
350 hGetContents :: Handle -> IO String
351 hGetContents handle =
352 wantReadableHandle "hGetContents" handle $ \handle_ -> do
353 xs <- lazyRead handle
354 return (handle_{ haType=SemiClosedHandle}, xs )
356 -- Note that someone may close the semi-closed handle (or change its
357 -- buffering), so each time these lazy read functions are pulled on,
358 -- they have to check whether the handle has indeed been closed.
360 lazyRead :: Handle -> IO String
363 withHandle "hGetContents" handle $ \ handle_ -> do
364 case haType handle_ of
365 ClosedHandle -> return (handle_, "")
366 SemiClosedHandle -> lazyReadBuffered handle handle_
368 (IOError (Just handle) IllegalOperation "hGetContents"
369 "illegal handle type" Nothing Nothing)
371 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
372 lazyReadBuffered h handle_@Handle__{..} = do
373 buf <- readIORef haCharBuffer
376 buf'@Buffer{..} <- getSomeCharacters handle_ buf
377 lazy_rest <- lazyRead h
378 (s,r) <- if haInputNL == CRLF
379 then unpack_nl bufRaw bufL bufR lazy_rest
380 else do s <- unpack bufRaw bufL bufR lazy_rest
382 writeIORef haCharBuffer (bufferAdjustL r buf')
385 (\e -> do (handle_', _) <- hClose_help handle_
386 debugIO ("hGetContents caught: " ++ show e)
387 -- We might have a \r cached in CRLF mode. So we
388 -- need to check for that and return it:
389 let r = if isEOFError e
390 then if not (isEmptyBuffer buf)
394 throw (augmentIOError e "hGetContents" h)
399 -- ensure we have some characters in the buffer
400 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
401 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
402 case bufferElems buf of
404 -- buffer empty: read some more
405 0 -> readTextDevice handle_ buf
407 -- if the buffer has a single '\r' in it and we're doing newline
408 -- translation: read some more
409 1 | haInputNL == CRLF -> do
410 (c,_) <- readCharBuf bufRaw bufL
412 then do -- shuffle the '\r' to the beginning. This is only safe
413 -- if we're about to call readTextDevice, otherwise it
414 -- would mess up flushCharBuffer.
415 -- See [note Buffer Flushing], GHC.IO.Handle.Types
416 _ <- writeCharBuf bufRaw 0 '\r'
417 let buf' = buf{ bufL=0, bufR=1 }
418 readTextDevice handle_ buf'
422 -- buffer has some chars in it already: just return it
426 -- ---------------------------------------------------------------------------
429 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
430 -- file or channel managed by @hdl@. Characters may be buffered if
431 -- buffering is enabled for @hdl@.
433 -- This operation may fail with:
435 -- * 'isFullError' if the device is full; or
437 -- * 'isPermissionError' if another system resource limit would be exceeded.
439 hPutChar :: Handle -> Char -> IO ()
440 hPutChar handle c = do
442 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
443 case haBufferMode handle_ of
444 LineBuffering -> hPutcBuffered handle_ True c
445 _other -> hPutcBuffered handle_ False c
447 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
448 hPutcBuffered handle_@Handle__{..} is_line c = do
449 buf <- readIORef haCharBuffer
451 then do buf1 <- if haOutputNL == CRLF
453 buf1 <- putc buf '\r'
459 flushed_buf <- flushWriteBuffer_ handle_ buf1
460 writeIORef haCharBuffer flushed_buf
462 writeIORef haCharBuffer buf1
465 writeIORef haCharBuffer buf1
467 putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
468 debugIO ("putc: " ++ summaryBuffer buf)
469 w' <- writeCharBuf raw w c
470 let buf' = buf{ bufR = w' }
471 if isFullCharBuffer buf'
472 then flushWriteBuffer_ handle_ buf'
475 -- ---------------------------------------------------------------------------
478 -- We go to some trouble to avoid keeping the handle locked while we're
479 -- evaluating the string argument to hPutStr, in case doing so triggers another
480 -- I/O operation on the same handle which would lead to deadlock. The classic
483 -- putStr (trace "hello" "world")
485 -- so the basic scheme is this:
487 -- * copy the string into a fresh buffer,
488 -- * "commit" the buffer to the handle.
490 -- Committing may involve simply copying the contents of the new
491 -- buffer into the handle's buffer, flushing one or both buffers, or
492 -- maybe just swapping the buffers over (if the handle's buffer was
493 -- empty). See commitBuffer below.
495 -- | Computation 'hPutStr' @hdl s@ writes the string
496 -- @s@ to the file or channel managed by @hdl@.
498 -- This operation may fail with:
500 -- * 'isFullError' if the device is full; or
502 -- * 'isPermissionError' if another system resource limit would be exceeded.
504 hPutStr :: Handle -> String -> IO ()
505 hPutStr handle str = do
507 wantWritableHandle "hPutStr" handle $ \h_ -> do
508 bmode <- getSpareBuffer h_
509 return (bmode, haOutputNL h_)
512 (NoBuffering, _) -> do
513 hPutChars handle str -- v. slow, but we don't care
514 (LineBuffering, buf) -> do
515 writeBlocks handle True nl buf str
516 (BlockBuffering _, buf) -> do
517 writeBlocks handle False nl buf str
519 hPutChars :: Handle -> [Char] -> IO ()
520 hPutChars _ [] = return ()
521 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
523 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
524 getSpareBuffer Handle__{haCharBuffer=ref,
529 NoBuffering -> return (mode, error "no buffer!")
531 bufs <- readIORef spare_ref
534 BufferListCons b rest -> do
535 writeIORef spare_ref rest
536 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
538 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
539 return (mode, new_buf)
542 -- NB. performance-critical code: eyeball the Core.
543 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
544 writeBlocks hdl line_buffered nl
545 buf@Buffer{ bufRaw=raw, bufSize=len } s =
547 shoveString :: Int -> [Char] -> IO ()
548 shoveString !n [] = do
549 _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-}
551 shoveString !n (c:cs)
552 -- n+1 so we have enough room to write '\r\n' if necessary
554 new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
555 writeBlocks hdl line_buffered nl new_buf (c:cs)
559 n1 <- writeCharBuf raw n '\r'
560 writeCharBuf raw n1 '\n'
565 new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
566 writeBlocks hdl line_buffered nl new_buf cs
570 n' <- writeCharBuf raw n c
575 -- -----------------------------------------------------------------------------
576 -- commitBuffer handle buf sz count flush release
578 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
579 -- 'count' bytes of data) to handle (handle must be block or line buffered).
583 -- for block/line buffering,
584 -- 1. If there isn't room in the handle buffer, flush the handle
587 -- 2. If the handle buffer is empty,
589 -- then write buf directly to the device.
590 -- else swap the handle buffer with buf.
592 -- 3. If the handle buffer is non-empty, copy buf into the
593 -- handle buffer. Then, if flush != 0, flush
597 :: Handle -- handle to commit to
598 -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
599 -> Int -- number of bytes of data in buffer
600 -> Bool -- True <=> flush the handle afterward
601 -> Bool -- release the buffer?
604 commitBuffer hdl !raw !sz !count flush release =
605 wantWritableHandle "commitAndReleaseBuffer" hdl $
606 commitBuffer' raw sz count flush release
607 {-# NOINLINE commitBuffer #-}
609 -- Explicitly lambda-lift this function to subvert GHC's full laziness
610 -- optimisations, which otherwise tends to float out subexpressions
611 -- past the \handle, which is really a pessimisation in this case because
612 -- that lambda is a one-shot lambda.
614 -- Don't forget to export the function, to stop it being inlined too
615 -- (this appears to be better than NOINLINE, because the strictness
616 -- analyser still gets to worker-wrapper it).
618 -- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
620 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
622 commitBuffer' raw sz@(I# _) count@(I# _) flush release
623 handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
625 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
626 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
628 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
632 -- enough room in handle buffer?
633 if (not flush && (size - w > count))
634 -- The > is to be sure that we never exactly fill
635 -- up the buffer, which would require a flush. So
636 -- if copying the new data into the buffer would
637 -- make the buffer full, we just flush the existing
638 -- buffer and the new data immediately, rather than
639 -- copying before flushing.
641 -- not flushing, and there's enough room in the buffer:
642 -- just copy the data in and update bufR.
643 then do withRawBuffer raw $ \praw ->
644 copyToRawBuffer old_raw (w*charSize)
645 praw (fromIntegral (count*charSize))
646 writeIORef ref old_buf{ bufR = w + count }
647 return (emptyBuffer raw sz WriteBuffer)
649 -- else, we have to flush
650 else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
653 Buffer{ bufRaw=raw, bufState=WriteBuffer,
654 bufL=0, bufR=count, bufSize=sz }
656 -- if: (a) we don't have to flush, and
657 -- (b) size(new buffer) == size(old buffer), and
658 -- (c) new buffer is not full,
659 -- we can just just swap them over...
660 if (not flush && sz == size && count /= sz)
662 writeIORef ref this_buf
665 -- otherwise, we have to flush the new data too,
666 -- and start with a fresh buffer
668 -- We're aren't going to use this buffer again
669 -- so we ignore the result of flushWriteBuffer_
670 _ <- flushWriteBuffer_ handle_ this_buf
671 writeIORef ref flushed_buf
672 -- if the sizes were different, then allocate
673 -- a new buffer of the correct size.
675 then return (emptyBuffer raw sz WriteBuffer)
676 else newCharBuffer size WriteBuffer
678 -- release the buffer if necessary
680 Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
681 if release && buf_ret_sz == size
683 spare_bufs <- readIORef spare_buf_ref
684 writeIORef spare_buf_ref
685 (BufferListCons buf_ret_raw spare_bufs)
690 -- ---------------------------------------------------------------------------
691 -- Reading/writing sequences of bytes.
693 -- ---------------------------------------------------------------------------
696 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
697 -- buffer @buf@ to the handle @hdl@. It returns ().
699 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
700 -- writing the bytes directly to the underlying file or device.
702 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
703 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
705 -- This operation may fail with:
707 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
708 -- reading end is closed. (If this is a POSIX system, and the program
709 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
710 -- instead, whose default action is to terminate the program).
712 hPutBuf :: Handle -- handle to write to
713 -> Ptr a -- address of buffer
714 -> Int -- number of bytes of data in buffer
716 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
720 :: Handle -- handle to write to
721 -> Ptr a -- address of buffer
722 -> Int -- number of bytes of data in buffer
723 -> IO Int -- returns: number of bytes written
724 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
726 hPutBuf':: Handle -- handle to write to
727 -> Ptr a -- address of buffer
728 -> Int -- number of bytes of data in buffer
729 -> Bool -- allow blocking?
731 hPutBuf' handle ptr count can_block
732 | count == 0 = return 0
733 | count < 0 = illegalBufferSize handle "hPutBuf" count
735 wantWritableHandle "hPutBuf" handle $
736 \ h_@Handle__{..} -> do
737 debugIO ("hPutBuf count=" ++ show count)
738 -- first flush the Char buffer if it is non-empty, then we
739 -- can work directly with the byte buffer
740 cbuf <- readIORef haCharBuffer
741 when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
743 r <- bufWrite h_ (castPtr ptr) count can_block
745 -- we must flush if this Handle is set to NoBuffering. If
746 -- it is set to LineBuffering, be conservative and flush
747 -- anyway (we didn't check for newlines in the data).
749 BlockBuffering _ -> do return ()
750 _line_or_no_buffering -> do flushWriteBuffer h_
753 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
754 bufWrite h_@Handle__{..} ptr count can_block =
755 seq count $ do -- strictness hack
756 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
757 <- readIORef haByteBuffer
759 -- enough room in handle buffer?
760 if (size - w > count)
761 -- There's enough room in the buffer:
762 -- just copy the data in and update bufR.
763 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
764 copyToRawBuffer old_raw w ptr (fromIntegral count)
765 writeIORef haByteBuffer old_buf{ bufR = w + count }
768 -- else, we have to flush
769 else do debugIO "hPutBuf: flushing first"
770 old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
771 -- TODO: we should do a non-blocking flush here
772 writeIORef haByteBuffer old_buf'
773 -- if we can fit in the buffer, then just loop
775 then bufWrite h_ ptr count can_block
777 then do writeChunk h_ (castPtr ptr) count
779 else writeChunkNonBlocking h_ (castPtr ptr) count
781 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
782 writeChunk h_@Handle__{..} ptr bytes
783 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
784 | otherwise = error "Todo: hPutBuf"
786 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
787 writeChunkNonBlocking h_@Handle__{..} ptr bytes
788 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
789 | otherwise = error "Todo: hPutBuf"
791 -- ---------------------------------------------------------------------------
794 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
795 -- into the buffer @buf@ until either EOF is reached or
796 -- @count@ 8-bit bytes have been read.
797 -- It returns the number of bytes actually read. This may be zero if
798 -- EOF was reached before any data was read (or if @count@ is zero).
800 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
801 -- smaller than @count@.
803 -- If the handle is a pipe or socket, and the writing end
804 -- is closed, 'hGetBuf' will behave as if EOF was reached.
806 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
807 -- on the 'Handle', and reads bytes directly.
809 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
811 | count == 0 = return 0
812 | count < 0 = illegalBufferSize h "hGetBuf" count
814 wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
815 flushCharReadBuffer h_
816 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
817 <- readIORef haByteBuffer
819 then bufReadEmpty h_ buf (castPtr ptr) 0 count
820 else bufReadNonEmpty h_ buf (castPtr ptr) 0 count
822 -- small reads go through the buffer, large reads are satisfied by
823 -- taking data first from the buffer and then direct from the file
826 bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
827 bufReadNonEmpty h_@Handle__{..}
828 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
834 copyFromRawBuffer ptr raw r count
835 writeIORef haByteBuffer buf{ bufL = r + count }
836 return (so_far + count)
839 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
840 let buf' = buf{ bufR=0, bufL=0 }
841 writeIORef haByteBuffer buf'
842 let remaining = count - avail
843 so_far' = so_far + avail
844 ptr' = ptr `plusPtr` avail
848 else bufReadEmpty h_ buf' ptr' so_far' remaining
851 bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
852 bufReadEmpty h_@Handle__{..}
853 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
855 | count > sz, Just fd <- cast haDevice = loop fd 0 count
857 (r,buf') <- Buffered.fillReadBuffer haDevice buf
860 else do writeIORef haByteBuffer buf'
861 bufReadNonEmpty h_ buf' ptr so_far count
863 loop :: FD -> Int -> Int -> IO Int
864 loop fd off bytes | bytes <= 0 = return off
865 loop fd off bytes = do
866 r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
868 then return (so_far + off)
869 else loop fd (off + r) (bytes - r)
871 -- ---------------------------------------------------------------------------
874 -- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@
875 -- into the buffer @buf@. If there is any data available to read,
876 -- then 'hGetBufSome' returns it immediately; it only blocks if there
877 -- is no data to be read.
879 -- It returns the number of bytes actually read. This may be zero if
880 -- EOF was reached before any data was read (or if @count@ is zero).
882 -- 'hGetBufSome' never raises an EOF exception, instead it returns a value
883 -- smaller than @count@.
885 -- If the handle is a pipe or socket, and the writing end
886 -- is closed, 'hGetBufSome' will behave as if EOF was reached.
888 -- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode'
889 -- on the 'Handle', and reads bytes directly.
891 hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
892 hGetBufSome h ptr count
893 | count == 0 = return 0
894 | count < 0 = illegalBufferSize h "hGetBuf" count
896 wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
897 flushCharReadBuffer h_
898 buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer
900 then if count > sz -- large read?
901 then do RawIO.read (haFD h_) (castPtr ptr) count
902 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
905 else do writeIORef haByteBuffer buf'
906 bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 count
908 bufReadNBEmpty h_ buf (castPtr ptr) 0 count
910 haFD :: Handle__ -> FD
911 haFD h_@Handle__{..} =
912 case cast haDevice of
913 Nothing -> error "not an FD"
916 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
917 -- into the buffer @buf@ until either EOF is reached, or
918 -- @count@ 8-bit bytes have been read, or there is no more data available
919 -- to read immediately.
921 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
922 -- never block waiting for data to become available, instead it returns
923 -- only whatever data is available. To wait for data to arrive before
924 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
926 -- If the handle is a pipe or socket, and the writing end
927 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
929 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
930 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
932 -- NOTE: on Windows, this function does not work correctly; it
933 -- behaves identically to 'hGetBuf'.
935 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
936 hGetBufNonBlocking h ptr count
937 | count == 0 = return 0
938 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
940 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do
941 flushCharReadBuffer h_
942 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
943 <- readIORef haByteBuffer
945 then bufReadNBEmpty h_ buf (castPtr ptr) 0 count
946 else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count
948 bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
949 bufReadNBEmpty h_@Handle__{..}
950 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
953 Just fd <- cast haDevice = do
954 m <- RawIO.readNonBlocking (fd::FD) ptr count
956 Nothing -> return so_far
957 Just n -> return (so_far + n)
960 buf <- readIORef haByteBuffer
961 (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
963 Nothing -> return so_far
964 Just 0 -> return so_far
966 writeIORef haByteBuffer buf'
967 bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
968 -- NOTE: new count is min count r
969 -- so we will just copy the contents of the
970 -- buffer in the recursive call, and not
974 bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
975 bufReadNBNonEmpty h_@Handle__{..}
976 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
982 copyFromRawBuffer ptr raw r count
983 writeIORef haByteBuffer buf{ bufL = r + count }
984 return (so_far + count)
987 copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
988 let buf' = buf{ bufR=0, bufL=0 }
989 writeIORef haByteBuffer buf'
990 let remaining = count - avail
991 so_far' = so_far + avail
992 ptr' = ptr `plusPtr` avail
996 else bufReadNBEmpty h_ buf' ptr' so_far' remaining
998 -- ---------------------------------------------------------------------------
1001 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
1002 copyToRawBuffer raw off ptr bytes =
1003 withRawBuffer raw $ \praw ->
1004 do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
1007 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
1008 copyFromRawBuffer ptr raw off bytes =
1009 withRawBuffer raw $ \praw ->
1010 do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
1013 foreign import ccall unsafe "memcpy"
1014 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
1016 -----------------------------------------------------------------------------
1019 illegalBufferSize :: Handle -> String -> Int -> IO a
1020 illegalBufferSize handle fn sz =
1021 ioException (IOError (Just handle)
1023 ("illegal buffer size " ++ showsPrec 9 sz [])