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