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