GHC/IO/Handle/Text.hs

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