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