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