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