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