949231b29d01b9c1af87388718a5c2d332524fed
[packages/base.git] / GHC / IO / Handle / Text.hs
1 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
2 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
3 {-# OPTIONS_HADDOCK hide #-}
4 {-# LANGUAGE NoImplicitPrelude, RecordWildCards, BangPatterns #-}
5
6 -----------------------------------------------------------------------------
7 -- |
8 -- Module : GHC.IO.Text
9 -- Copyright : (c) The University of Glasgow, 1992-2008
10 -- License : see libraries/base/LICENSE
11 --
12 -- Maintainer : libraries@haskell.org
13 -- Stability : internal
14 -- Portability : non-portable
15 --
16 -- String I\/O functions
17 --
18 -----------------------------------------------------------------------------
19
20 -- #hide
21 module GHC.IO.Handle.Text (
22 hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
23 commitBuffer', -- hack, see below
24 hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking,
25 memcpy, hPutStrLn,
26 ) where
27
28 import GHC.IO
29 import GHC.IO.FD
30 import GHC.IO.Buffer
31 import qualified GHC.IO.BufferedIO as Buffered
32 import GHC.IO.Exception
33 import GHC.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
38
39 import Foreign
40 import Foreign.C
41
42 import qualified Control.Exception as Exception
43 import Data.Typeable
44 import System.IO.Error
45 import Data.Maybe
46 import Control.Monad
47
48 import GHC.IORef
49 import GHC.Base
50 import GHC.Real
51 import GHC.Num
52 import GHC.Show
53 import GHC.List
54
55 -- ---------------------------------------------------------------------------
56 -- Simple input operations
57
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.
62
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.
70 --
71 -- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely.
72 --
73 -- This operation may fail with:
74 --
75 -- * 'isEOFError' if the end of file has been reached.
76 --
77 -- * a decoding error, if the input begins with an invalid byte sequence
78 -- in this Handle's encoding.
79 --
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.
84 --
85
86 hWaitForInput :: Handle -> Int -> IO Bool
87 hWaitForInput h msecs = do
88 wantReadableHandle_ "hWaitForInput" h $ \ handle_@Handle__{..} -> do
89 cbuf <- readIORef haCharBuffer
90
91 if not (isEmptyBuffer cbuf) then return True else do
92
93 if msecs < 0
94 then do cbuf' <- readTextDevice handle_ cbuf
95 writeIORef haCharBuffer cbuf'
96 return True
97 else do
98 -- there might be bytes in the byte buffer waiting to be decoded
99 cbuf' <- decodeByteBuf handle_ cbuf
100 writeIORef haCharBuffer cbuf'
101
102 if not (isEmptyBuffer cbuf') then return True else do
103
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_
108 return True
109 else return False
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
114 -- so far.
115
116 -- ---------------------------------------------------------------------------
117 -- hGetChar
118
119 -- | Computation 'hGetChar' @hdl@ reads a character from the file or
120 -- channel managed by @hdl@, blocking until a character is available.
121 --
122 -- This operation may fail with:
123 --
124 -- * 'isEOFError' if the end of file has been reached.
125
126 hGetChar :: Handle -> IO Char
127 hGetChar handle =
128 wantReadableHandle_ "hGetChar" handle $ \handle_@Handle__{..} -> do
129
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
135
136 buf1 <- if isEmptyBuffer buf0
137 then readTextDevice handle_ buf0
138 else return buf0
139
140 (c1,i) <- readCharBuf (bufRaw buf1) (bufL buf1)
141 let buf2 = bufferAdjustL i buf1
142
143 if haInputNL == CRLF && c1 == '\r'
144 then do
145 mbuf3 <- if isEmptyBuffer buf2
146 then maybeFillReadBuffer handle_ buf2
147 else return (Just buf2)
148
149 case mbuf3 of
150 -- EOF, so just return the '\r' we have
151 Nothing -> do
152 writeIORef haCharBuffer buf2
153 return '\r'
154 Just buf3 -> do
155 (c2,i2) <- readCharBuf (bufRaw buf2) (bufL buf2)
156 if c2 == '\n'
157 then do
158 writeIORef haCharBuffer (bufferAdjustL i2 buf3)
159 return '\n'
160 else do
161 -- not a \r\n sequence, so just return the \r
162 writeIORef haCharBuffer buf3
163 return '\r'
164 else do
165 writeIORef haCharBuffer buf2
166 return c1
167
168 -- ---------------------------------------------------------------------------
169 -- hGetLine
170
171 -- | Computation 'hGetLine' @hdl@ reads a line from the file or
172 -- channel managed by @hdl@.
173 --
174 -- This operation may fail with:
175 --
176 -- * 'isEOFError' if the end of file is encountered when reading
177 -- the /first/ character of the line.
178 --
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)
181 -- line is returned.
182
183 hGetLine :: Handle -> IO String
184 hGetLine h =
185 wantReadableHandle_ "hGetLine" h $ \ handle_ -> do
186 hGetLineBuffered handle_
187
188 hGetLineBuffered :: Handle__ -> IO String
189 hGetLineBuffered handle_@Handle__{..} = do
190 buf <- readIORef haCharBuffer
191 hGetLineBufferedLoop handle_ buf []
192
193 hGetLineBufferedLoop :: Handle__
194 -> CharBuffer -> [String]
195 -> IO String
196 hGetLineBufferedLoop handle_@Handle__{..}
197 buf@Buffer{ bufL=r0, bufR=w, bufRaw=raw0 } xss =
198 let
199 -- find the end-of-line character, if there is one
200 loop raw r
201 | r == w = return (False, w)
202 | otherwise = do
203 (c,r') <- readCharBuf raw r
204 if c == '\n'
205 then return (True, r) -- NB. not r': don't include the '\n'
206 else loop raw r'
207 in do
208 (eol, off) <- loop raw0 r0
209
210 debugIO ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off)
211
212 (xs,r') <- if haInputNL == CRLF
213 then unpack_nl raw0 r0 off ""
214 else do xs <- unpack raw0 r0 off ""
215 return (xs,off)
216
217 -- if eol == True, then off is the offset of the '\n'
218 -- otherwise off == w and the buffer is now empty.
219 if eol -- r' == off
220 then do writeIORef haCharBuffer (bufferAdjustL (off+1) buf)
221 return (concat (reverse (xs:xss)))
222 else do
223 let buf1 = bufferAdjustL r' buf
224 maybe_buf <- maybeFillReadBuffer handle_ buf1
225 case maybe_buf of
226 -- Nothing indicates we caught an EOF, and we may have a
227 -- partial line to return.
228 Nothing -> do
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.
232 --
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))
236 if not (null str)
237 then return str
238 else ioe_EOF
239 Just new_buf ->
240 hGetLineBufferedLoop handle_ new_buf (xs:xss)
241
242 maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer)
243 maybeFillReadBuffer handle_ buf
244 = Exception.catch
245 (do buf' <- getSomeCharacters handle_ buf
246 return (Just buf')
247 )
248 (\e -> do if isEOFError e
249 then return Nothing
250 else ioError e)
251
252 -- See GHC.IO.Buffer
253 #define CHARBUF_UTF32
254 -- #define CHARBUF_UTF16
255
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
260 | otherwise =
261 withRawBuffer buf $ \pbuf ->
262 let
263 unpackRB acc !i
264 | i < r = return acc
265 | otherwise = do
266 #ifdef CHARBUF_UTF16
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)
275 #else
276 c <- peekElemOff pbuf i
277 unpackRB (c:acc) (i-1)
278 #endif
279 in
280 unpackRB acc0 (w-1)
281
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)
286 | otherwise =
287 withRawBuffer buf $ \pbuf ->
288 let
289 unpackRB acc !i
290 | i < r = return acc
291 | otherwise = do
292 c <- peekElemOff pbuf i
293 if (c == '\n' && i > r)
294 then do
295 c1 <- peekElemOff pbuf (i-1)
296 if (c1 == '\r')
297 then unpackRB ('\n':acc) (i-2)
298 else unpackRB ('\n':acc) (i-1)
299 else do
300 unpackRB (c:acc) (i-1)
301 in do
302 c <- peekElemOff pbuf (w-1)
303 if (c == '\r')
304 then do
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)
309 return (str, w-1)
310 else do
311 str <- unpackRB acc0 (w-1)
312 return (str, w)
313
314
315 -- -----------------------------------------------------------------------------
316 -- hGetContents
317
318 -- hGetContents on a DuplexHandle only affects the read side: you can
319 -- carry on writing to it afterwards.
320
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@.
327 --
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:
331 --
332 -- * if 'hClose' is applied to it;
333 --
334 -- * if an I\/O error occurs when reading an item from the handle;
335 --
336 -- * or once the entire contents of the handle has been read.
337 --
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.
342 --
343 -- Any I\/O errors encountered while a handle is semi-closed are simply
344 -- discarded.
345 --
346 -- This operation may fail with:
347 --
348 -- * 'isEOFError' if the end of file has been reached.
349
350 hGetContents :: Handle -> IO String
351 hGetContents handle =
352 wantReadableHandle "hGetContents" handle $ \handle_ -> do
353 xs <- lazyRead handle
354 return (handle_{ haType=SemiClosedHandle}, xs )
355
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.
359
360 lazyRead :: Handle -> IO String
361 lazyRead handle =
362 unsafeInterleaveIO $
363 withHandle "hGetContents" handle $ \ handle_ -> do
364 case haType handle_ of
365 ClosedHandle -> return (handle_, "")
366 SemiClosedHandle -> lazyReadBuffered handle handle_
367 _ -> ioException
368 (IOError (Just handle) IllegalOperation "hGetContents"
369 "illegal handle type" Nothing Nothing)
370
371 lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char])
372 lazyReadBuffered h handle_@Handle__{..} = do
373 buf <- readIORef haCharBuffer
374 Exception.catch
375 (do
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
381 return (s,bufR)
382 writeIORef haCharBuffer (bufferAdjustL r buf')
383 return (handle_, s)
384 )
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)
391 then "\r"
392 else ""
393 else
394 throw (augmentIOError e "hGetContents" h)
395
396 return (handle_', r)
397 )
398
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
403
404 -- buffer empty: read some more
405 0 -> readTextDevice handle_ buf
406
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
411 if c == '\r'
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'
419 else do
420 return buf
421
422 -- buffer has some chars in it already: just return it
423 _otherwise ->
424 return buf
425
426 -- ---------------------------------------------------------------------------
427 -- hPutChar
428
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@.
432 --
433 -- This operation may fail with:
434 --
435 -- * 'isFullError' if the device is full; or
436 --
437 -- * 'isPermissionError' if another system resource limit would be exceeded.
438
439 hPutChar :: Handle -> Char -> IO ()
440 hPutChar handle c = do
441 c `seq` return ()
442 wantWritableHandle "hPutChar" handle $ \ handle_ -> do
443 hPutcBuffered handle_ c
444
445 hPutcBuffered :: Handle__ -> Char -> IO ()
446 hPutcBuffered handle_@Handle__{..} c = do
447 buf <- readIORef haCharBuffer
448 if c == '\n'
449 then do buf1 <- if haOutputNL == CRLF
450 then do
451 buf1 <- putc buf '\r'
452 putc buf1 '\n'
453 else do
454 putc buf '\n'
455 writeCharBuffer handle_ buf1
456 when is_line $ flushByteWriteBuffer handle_
457 else do
458 buf1 <- putc buf c
459 writeCharBuffer handle_ buf1
460 return ()
461 where
462 is_line = case haBufferMode of
463 LineBuffering -> True
464 _ -> False
465
466 putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
467 debugIO ("putc: " ++ summaryBuffer buf)
468 w' <- writeCharBuf raw w c
469 return buf{ bufR = w' }
470
471 -- ---------------------------------------------------------------------------
472 -- hPutStr
473
474 -- We go to some trouble to avoid keeping the handle locked while we're
475 -- evaluating the string argument to hPutStr, in case doing so triggers another
476 -- I/O operation on the same handle which would lead to deadlock. The classic
477 -- case is
478 --
479 -- putStr (trace "hello" "world")
480 --
481 -- so the basic scheme is this:
482 --
483 -- * copy the string into a fresh buffer,
484 -- * "commit" the buffer to the handle.
485 --
486 -- Committing may involve simply copying the contents of the new
487 -- buffer into the handle's buffer, flushing one or both buffers, or
488 -- maybe just swapping the buffers over (if the handle's buffer was
489 -- empty). See commitBuffer below.
490
491 -- | Computation 'hPutStr' @hdl s@ writes the string
492 -- @s@ to the file or channel managed by @hdl@.
493 --
494 -- This operation may fail with:
495 --
496 -- * 'isFullError' if the device is full; or
497 --
498 -- * 'isPermissionError' if another system resource limit would be exceeded.
499
500 hPutStr :: Handle -> String -> IO ()
501 hPutStr handle str = hPutStr' handle str False
502
503 -- | The same as 'hPutStr', but adds a newline character.
504 hPutStrLn :: Handle -> String -> IO ()
505 hPutStrLn handle str = hPutStr' handle str True
506 -- An optimisation: we treat hPutStrLn specially, to avoid the
507 -- overhead of a single putChar '\n', which is quite high now that we
508 -- have to encode eagerly.
509
510 hPutStr' :: Handle -> String -> Bool -> IO ()
511 hPutStr' handle str add_nl =
512 do
513 (buffer_mode, nl) <-
514 wantWritableHandle "hPutStr" handle $ \h_ -> do
515 bmode <- getSpareBuffer h_
516 return (bmode, haOutputNL h_)
517
518 case buffer_mode of
519 (NoBuffering, _) -> do
520 hPutChars handle str -- v. slow, but we don't care
521 when add_nl $ hPutChar handle '\n'
522 (LineBuffering, buf) -> do
523 writeBlocks handle True add_nl nl buf str
524 (BlockBuffering _, buf) -> do
525 writeBlocks handle False add_nl nl buf str
526
527 hPutChars :: Handle -> [Char] -> IO ()
528 hPutChars _ [] = return ()
529 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
530
531 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
532 getSpareBuffer Handle__{haCharBuffer=ref,
533 haBuffers=spare_ref,
534 haBufferMode=mode}
535 = do
536 case mode of
537 NoBuffering -> return (mode, error "no buffer!")
538 _ -> do
539 bufs <- readIORef spare_ref
540 buf <- readIORef ref
541 case bufs of
542 BufferListCons b rest -> do
543 writeIORef spare_ref rest
544 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
545 BufferListNil -> do
546 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
547 return (mode, new_buf)
548
549
550 -- NB. performance-critical code: eyeball the Core.
551 writeBlocks :: Handle -> Bool -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
552 writeBlocks hdl line_buffered add_nl nl
553 buf@Buffer{ bufRaw=raw, bufSize=len } s =
554 let
555 shoveString :: Int -> [Char] -> [Char] -> IO ()
556 shoveString !n [] [] = do
557 commitBuffer hdl raw len n False{-no flush-} True{-release-}
558 shoveString !n [] rest = do
559 shoveString n rest []
560 shoveString !n (c:cs) rest
561 -- n+1 so we have enough room to write '\r\n' if necessary
562 | n + 1 >= len = do
563 commitBuffer hdl raw len n False{-flush-} False
564 shoveString 0 (c:cs) rest
565 | c == '\n' = do
566 n' <- if nl == CRLF
567 then do
568 n1 <- writeCharBuf raw n '\r'
569 writeCharBuf raw n1 '\n'
570 else do
571 writeCharBuf raw n c
572 if line_buffered
573 then do
574 -- end of line, so write and flush
575 commitBuffer hdl raw len n' True{-flush-} False
576 shoveString 0 cs rest
577 else do
578 shoveString n' cs rest
579 | otherwise = do
580 n' <- writeCharBuf raw n c
581 shoveString n' cs rest
582 in
583 shoveString 0 s (if add_nl then "\n" else "")
584
585 -- -----------------------------------------------------------------------------
586 -- commitBuffer handle buf sz count flush release
587 --
588 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
589 -- 'count' bytes of data) to handle (handle must be block or line buffered).
590
591 commitBuffer
592 :: Handle -- handle to commit to
593 -> RawCharBuffer -> Int -- address and size (in bytes) of buffer
594 -> Int -- number of bytes of data in buffer
595 -> Bool -- True <=> flush the handle afterward
596 -> Bool -- release the buffer?
597 -> IO ()
598
599 commitBuffer hdl !raw !sz !count flush release =
600 wantWritableHandle "commitBuffer" hdl $ \h_@Handle__{..} -> do
601 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
602 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
603
604 writeCharBuffer h_ Buffer{ bufRaw=raw, bufState=WriteBuffer,
605 bufL=0, bufR=count, bufSize=sz }
606
607 when flush $ flushByteWriteBuffer h_
608
609 -- release the buffer if necessary
610 when release $ do
611 -- find size of current buffer
612 old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
613 when (sz == size) $ do
614 spare_bufs <- readIORef haBuffers
615 writeIORef haBuffers (BufferListCons raw spare_bufs)
616
617 return ()
618
619 -- backwards compatibility; the text package uses this
620 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
621 -> IO CharBuffer
622 commitBuffer' raw sz@(I# _) count@(I# _) flush release h_@Handle__{..}
623 = do
624 debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
625 ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
626
627 let this_buf = Buffer{ bufRaw=raw, bufState=WriteBuffer,
628 bufL=0, bufR=count, bufSize=sz }
629
630 writeCharBuffer h_ this_buf
631
632 when flush $ flushByteWriteBuffer h_
633
634 -- release the buffer if necessary
635 when release $ do
636 -- find size of current buffer
637 old_buf@Buffer{ bufSize=size } <- readIORef haCharBuffer
638 when (sz == size) $ do
639 spare_bufs <- readIORef haBuffers
640 writeIORef haBuffers (BufferListCons raw spare_bufs)
641
642 return this_buf
643
644 -- ---------------------------------------------------------------------------
645 -- Reading/writing sequences of bytes.
646
647 -- ---------------------------------------------------------------------------
648 -- hPutBuf
649
650 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
651 -- buffer @buf@ to the handle @hdl@. It returns ().
652 --
653 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
654 -- writing the bytes directly to the underlying file or device.
655 --
656 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
657 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
658 --
659 -- This operation may fail with:
660 --
661 -- * 'ResourceVanished' if the handle is a pipe or socket, and the
662 -- reading end is closed. (If this is a POSIX system, and the program
663 -- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
664 -- instead, whose default action is to terminate the program).
665
666 hPutBuf :: Handle -- handle to write to
667 -> Ptr a -- address of buffer
668 -> Int -- number of bytes of data in buffer
669 -> IO ()
670 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
671 return ()
672
673 hPutBufNonBlocking
674 :: Handle -- handle to write to
675 -> Ptr a -- address of buffer
676 -> Int -- number of bytes of data in buffer
677 -> IO Int -- returns: number of bytes written
678 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
679
680 hPutBuf':: Handle -- handle to write to
681 -> Ptr a -- address of buffer
682 -> Int -- number of bytes of data in buffer
683 -> Bool -- allow blocking?
684 -> IO Int
685 hPutBuf' handle ptr count can_block
686 | count == 0 = return 0
687 | count < 0 = illegalBufferSize handle "hPutBuf" count
688 | otherwise =
689 wantWritableHandle "hPutBuf" handle $
690 \ h_@Handle__{..} -> do
691 debugIO ("hPutBuf count=" ++ show count)
692
693 r <- bufWrite h_ (castPtr ptr) count can_block
694
695 -- we must flush if this Handle is set to NoBuffering. If
696 -- it is set to LineBuffering, be conservative and flush
697 -- anyway (we didn't check for newlines in the data).
698 case haBufferMode of
699 BlockBuffering _ -> do return ()
700 _line_or_no_buffering -> do flushWriteBuffer h_
701 return r
702
703 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
704 bufWrite h_@Handle__{..} ptr count can_block =
705 seq count $ do -- strictness hack
706 old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
707 <- readIORef haByteBuffer
708
709 -- enough room in handle buffer?
710 if (size - w > count)
711 -- There's enough room in the buffer:
712 -- just copy the data in and update bufR.
713 then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
714 copyToRawBuffer old_raw w ptr count
715 writeIORef haByteBuffer old_buf{ bufR = w + count }
716 return count
717
718 -- else, we have to flush
719 else do debugIO "hPutBuf: flushing first"
720 old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
721 -- TODO: we should do a non-blocking flush here
722 writeIORef haByteBuffer old_buf'
723 -- if we can fit in the buffer, then just loop
724 if count < size
725 then bufWrite h_ ptr count can_block
726 else if can_block
727 then do writeChunk h_ (castPtr ptr) count
728 return count
729 else writeChunkNonBlocking h_ (castPtr ptr) count
730
731 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
732 writeChunk h_@Handle__{..} ptr bytes
733 | Just fd <- cast haDevice = RawIO.write (fd::FD) ptr bytes
734 | otherwise = error "Todo: hPutBuf"
735
736 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
737 writeChunkNonBlocking h_@Handle__{..} ptr bytes
738 | Just fd <- cast haDevice = RawIO.writeNonBlocking (fd::FD) ptr bytes
739 | otherwise = error "Todo: hPutBuf"
740
741 -- ---------------------------------------------------------------------------
742 -- hGetBuf
743
744 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
745 -- into the buffer @buf@ until either EOF is reached or
746 -- @count@ 8-bit bytes have been read.
747 -- It returns the number of bytes actually read. This may be zero if
748 -- EOF was reached before any data was read (or if @count@ is zero).
749 --
750 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
751 -- smaller than @count@.
752 --
753 -- If the handle is a pipe or socket, and the writing end
754 -- is closed, 'hGetBuf' will behave as if EOF was reached.
755 --
756 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
757 -- on the 'Handle', and reads bytes directly.
758
759 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
760 hGetBuf h ptr count
761 | count == 0 = return 0
762 | count < 0 = illegalBufferSize h "hGetBuf" count
763 | otherwise =
764 wantReadableHandle_ "hGetBuf" h $ \ h_@Handle__{..} -> do
765 flushCharReadBuffer h_
766 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
767 <- readIORef haByteBuffer
768 if isEmptyBuffer buf
769 then bufReadEmpty h_ buf (castPtr ptr) 0 count
770 else bufReadNonEmpty h_ buf (castPtr ptr) 0 count
771
772 -- small reads go through the buffer, large reads are satisfied by
773 -- taking data first from the buffer and then direct from the file
774 -- descriptor.
775
776 bufReadNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
777 bufReadNonEmpty h_@Handle__{..}
778 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
779 ptr !so_far !count
780 = do
781 let avail = w - r
782 if (count < avail)
783 then do
784 copyFromRawBuffer ptr raw r count
785 writeIORef haByteBuffer buf{ bufL = r + count }
786 return (so_far + count)
787 else do
788
789 copyFromRawBuffer ptr raw r avail
790 let buf' = buf{ bufR=0, bufL=0 }
791 writeIORef haByteBuffer buf'
792 let remaining = count - avail
793 so_far' = so_far + avail
794 ptr' = ptr `plusPtr` avail
795
796 if remaining == 0
797 then return so_far'
798 else bufReadEmpty h_ buf' ptr' so_far' remaining
799
800
801 bufReadEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
802 bufReadEmpty h_@Handle__{..}
803 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
804 ptr so_far count
805 | count > sz, Just fd <- cast haDevice = loop fd 0 count
806 | otherwise = do
807 (r,buf') <- Buffered.fillReadBuffer haDevice buf
808 if r == 0
809 then return so_far
810 else do writeIORef haByteBuffer buf'
811 bufReadNonEmpty h_ buf' ptr so_far count
812 where
813 loop :: FD -> Int -> Int -> IO Int
814 loop fd off bytes | bytes <= 0 = return (so_far + off)
815 loop fd off bytes = do
816 r <- RawIO.read (fd::FD) (ptr `plusPtr` off) bytes
817 if r == 0
818 then return (so_far + off)
819 else loop fd (off + r) (bytes - r)
820
821 -- ---------------------------------------------------------------------------
822 -- hGetBufSome
823
824 -- | 'hGetBufSome' @hdl buf count@ reads data from the handle @hdl@
825 -- into the buffer @buf@. If there is any data available to read,
826 -- then 'hGetBufSome' returns it immediately; it only blocks if there
827 -- is no data to be read.
828 --
829 -- It returns the number of bytes actually read. This may be zero if
830 -- EOF was reached before any data was read (or if @count@ is zero).
831 --
832 -- 'hGetBufSome' never raises an EOF exception, instead it returns a value
833 -- smaller than @count@.
834 --
835 -- If the handle is a pipe or socket, and the writing end
836 -- is closed, 'hGetBufSome' will behave as if EOF was reached.
837 --
838 -- 'hGetBufSome' ignores the prevailing 'TextEncoding' and 'NewlineMode'
839 -- on the 'Handle', and reads bytes directly.
840
841 hGetBufSome :: Handle -> Ptr a -> Int -> IO Int
842 hGetBufSome h ptr count
843 | count == 0 = return 0
844 | count < 0 = illegalBufferSize h "hGetBufSome" count
845 | otherwise =
846 wantReadableHandle_ "hGetBufSome" h $ \ h_@Handle__{..} -> do
847 flushCharReadBuffer h_
848 buf@Buffer{ bufSize=sz } <- readIORef haByteBuffer
849 if isEmptyBuffer buf
850 then if count > sz -- large read?
851 then do RawIO.read (haFD h_) (castPtr ptr) count
852 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
853 if r == 0
854 then return 0
855 else do writeIORef haByteBuffer buf'
856 bufReadNBNonEmpty h_ buf' (castPtr ptr) 0 (min r count)
857 -- new count is (min r count), so
858 -- that bufReadNBNonEmpty will not
859 -- issue another read.
860 else
861 bufReadNBEmpty h_ buf (castPtr ptr) 0 count
862
863 haFD :: Handle__ -> FD
864 haFD h_@Handle__{..} =
865 case cast haDevice of
866 Nothing -> error "not an FD"
867 Just fd -> fd
868
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.
873 --
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'.
878 --
879 -- If the handle is a pipe or socket, and the writing end
880 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
881 --
882 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
883 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
884 --
885 -- NOTE: on Windows, this function does not work correctly; it
886 -- behaves identically to 'hGetBuf'.
887
888 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
889 hGetBufNonBlocking h ptr count
890 | count == 0 = return 0
891 | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count
892 | otherwise =
893 wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_@Handle__{..} -> do
894 flushCharReadBuffer h_
895 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
896 <- readIORef haByteBuffer
897 if isEmptyBuffer buf
898 then bufReadNBEmpty h_ buf (castPtr ptr) 0 count
899 else bufReadNBNonEmpty h_ buf (castPtr ptr) 0 count
900
901 bufReadNBEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
902 bufReadNBEmpty h_@Handle__{..}
903 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
904 ptr so_far count
905 | count > sz,
906 Just fd <- cast haDevice = do
907 m <- RawIO.readNonBlocking (fd::FD) ptr count
908 case m of
909 Nothing -> return so_far
910 Just n -> return (so_far + n)
911
912 | otherwise = do
913 buf <- readIORef haByteBuffer
914 (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
915 case r of
916 Nothing -> return so_far
917 Just 0 -> return so_far
918 Just r -> do
919 writeIORef haByteBuffer buf'
920 bufReadNBNonEmpty h_ buf' ptr so_far (min count r)
921 -- NOTE: new count is min count r
922 -- so we will just copy the contents of the
923 -- buffer in the recursive call, and not
924 -- loop again.
925
926
927 bufReadNBNonEmpty :: Handle__ -> Buffer Word8 -> Ptr Word8 -> Int -> Int -> IO Int
928 bufReadNBNonEmpty h_@Handle__{..}
929 buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz }
930 ptr so_far count
931 = do
932 let avail = w - r
933 if (count < avail)
934 then do
935 copyFromRawBuffer ptr raw r count
936 writeIORef haByteBuffer buf{ bufL = r + count }
937 return (so_far + count)
938 else do
939
940 copyFromRawBuffer ptr raw r avail
941 let buf' = buf{ bufR=0, bufL=0 }
942 writeIORef haByteBuffer buf'
943 let remaining = count - avail
944 so_far' = so_far + avail
945 ptr' = ptr `plusPtr` avail
946
947 if remaining == 0
948 then return so_far'
949 else bufReadNBEmpty h_ buf' ptr' so_far' remaining
950
951 -- ---------------------------------------------------------------------------
952 -- memcpy wrappers
953
954 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
955 copyToRawBuffer raw off ptr bytes =
956 withRawBuffer raw $ \praw ->
957 do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
958 return ()
959
960 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
961 copyFromRawBuffer ptr raw off bytes =
962 withRawBuffer raw $ \praw ->
963 do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
964 return ()
965
966 foreign import ccall unsafe "memcpy"
967 memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
968
969 -----------------------------------------------------------------------------
970 -- Internal Utils
971
972 illegalBufferSize :: Handle -> String -> Int -> IO a
973 illegalBufferSize handle fn sz =
974 ioException (IOError (Just handle)
975 InvalidArgument fn
976 ("illegal buffer size " ++ showsPrec 9 sz [])
977 Nothing Nothing)