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 "hGetContents" handle $ \ handle_ -> do
 359         case haType handle_ of
 360           ClosedHandle     -> return (handle_, "")
 361           SemiClosedHandle -> lazyReadBuffered handle handle_
 362           _ -> ioException
 363                   (IOError (Just handle) IllegalOperation "hGetContents"
 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         (\e -> do (handle_', _) <- hClose_help handle_
 381                   debugIO ("hGetContents caught: " ++ show e)
 382                   -- We might have a \r cached in CRLF mode.  So we
 383                   -- need to check for that and return it:
 384                   if isEOFError e
 385                      then if not (isEmptyBuffer buf)
 386                              then return (handle_', "\r")
 387                              else return (handle_', "")
 388                      else ioError e
 389         )
 390
 391 -- ensure we have some characters in the buffer
 392 getSomeCharacters :: Handle__ -> CharBuffer -> IO CharBuffer
 393 getSomeCharacters handle_@Handle__{..} buf@Buffer{..} =
 394   case bufferElems buf of
 395
 396     -- buffer empty: read some more
 397     0 -> readTextDevice handle_ buf
 398
 399     -- if the buffer has a single '\r' in it and we're doing newline
 400     -- translation: read some more
 401     1 | haInputNL == CRLF -> do
 402       (c,_) <- readCharBuf bufRaw bufL
 403       if c == '\r'
 404          then do -- shuffle the '\r' to the beginning.  This is only safe
 405                  -- if we're about to call readTextDevice, otherwise it
 406                  -- would mess up flushCharBuffer.
 407                  -- See [note Buffer Flushing], GHC.IO.Handle.Types
 408                  _ <- writeCharBuf bufRaw 0 '\r'
 409                  let buf' = buf{ bufL=0, bufR=1 }
 410                  readTextDevice handle_ buf'
 411          else do
 412                  return buf
 413
 414     -- buffer has some chars in it already: just return it
 415     _otherwise ->
 416       return buf
 417
 418 -- ---------------------------------------------------------------------------
 419 -- hPutChar
 420
 421 -- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the
 422 -- file or channel managed by @hdl@.  Characters may be buffered if
 423 -- buffering is enabled for @hdl@.
 424 --
 425 -- This operation may fail with:
 426 --
 427 --  * 'isFullError' if the device is full; or
 428 --
 429 --  * 'isPermissionError' if another system resource limit would be exceeded.
 430
 431 hPutChar :: Handle -> Char -> IO ()
 432 hPutChar handle c = do
 433     c `seq` return ()
 434     wantWritableHandle "hPutChar" handle $ \ handle_  -> do
 435     case haBufferMode handle_ of
 436         LineBuffering -> hPutcBuffered handle_ True  c
 437         _other        -> hPutcBuffered handle_ False c
 438
 439 hPutcBuffered :: Handle__ -> Bool -> Char -> IO ()
 440 hPutcBuffered handle_@Handle__{..} is_line c = do
 441   buf <- readIORef haCharBuffer
 442   if c == '\n'
 443      then do buf1 <- if haOutputNL == CRLF
 444                         then do
 445                           buf1 <- putc buf '\r'
 446                           putc buf1 '\n'
 447                         else do
 448                           putc buf '\n'
 449              if is_line
 450                 then do
 451                   flushed_buf <- flushWriteBuffer_ handle_ buf1
 452                   writeIORef haCharBuffer flushed_buf
 453                 else
 454                   writeIORef haCharBuffer buf1
 455       else do
 456           buf1 <- putc buf c
 457           writeIORef haCharBuffer buf1
 458   where
 459     putc buf@Buffer{ bufRaw=raw, bufR=w } c = do
 460        debugIO ("putc: " ++ summaryBuffer buf)
 461        w'  <- writeCharBuf raw w c
 462        let buf' = buf{ bufR = w' }
 463        if isFullCharBuffer buf'
 464           then flushWriteBuffer_ handle_ buf'
 465           else return buf'
 466
 467 -- ---------------------------------------------------------------------------
 468 -- hPutStr
 469
 470 -- We go to some trouble to avoid keeping the handle locked while we're
 471 -- evaluating the string argument to hPutStr, in case doing so triggers another
 472 -- I/O operation on the same handle which would lead to deadlock.  The classic
 473 -- case is
 474 --
 475 --              putStr (trace "hello" "world")
 476 --
 477 -- so the basic scheme is this:
 478 --
 479 --      * copy the string into a fresh buffer,
 480 --      * "commit" the buffer to the handle.
 481 --
 482 -- Committing may involve simply copying the contents of the new
 483 -- buffer into the handle's buffer, flushing one or both buffers, or
 484 -- maybe just swapping the buffers over (if the handle's buffer was
 485 -- empty).  See commitBuffer below.
 486
 487 -- | Computation 'hPutStr' @hdl s@ writes the string
 488 -- @s@ to the file or channel managed by @hdl@.
 489 --
 490 -- This operation may fail with:
 491 --
 492 --  * 'isFullError' if the device is full; or
 493 --
 494 --  * 'isPermissionError' if another system resource limit would be exceeded.
 495
 496 hPutStr :: Handle -> String -> IO ()
 497 hPutStr handle str = do
 498     (buffer_mode, nl) <-
 499          wantWritableHandle "hPutStr" handle $ \h_ -> do
 500                        bmode <- getSpareBuffer h_
 501                        return (bmode, haOutputNL h_)
 502
 503     case buffer_mode of
 504        (NoBuffering, _) -> do
 505             hPutChars handle str        -- v. slow, but we don't care
 506        (LineBuffering, buf) -> do
 507             writeBlocks handle True  nl buf str
 508        (BlockBuffering _, buf) -> do
 509             writeBlocks handle False nl buf str
 510
 511 hPutChars :: Handle -> [Char] -> IO ()
 512 hPutChars _      [] = return ()
 513 hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
 514
 515 getSpareBuffer :: Handle__ -> IO (BufferMode, CharBuffer)
 516 getSpareBuffer Handle__{haCharBuffer=ref,
 517                         haBuffers=spare_ref,
 518                         haBufferMode=mode}
 519  = do
 520    case mode of
 521      NoBuffering -> return (mode, error "no buffer!")
 522      _ -> do
 523           bufs <- readIORef spare_ref
 524           buf  <- readIORef ref
 525           case bufs of
 526             BufferListCons b rest -> do
 527                 writeIORef spare_ref rest
 528                 return ( mode, emptyBuffer b (bufSize buf) WriteBuffer)
 529             BufferListNil -> do
 530                 new_buf <- newCharBuffer (bufSize buf) WriteBuffer
 531                 return (mode, new_buf)
 532
 533
 534 -- NB. performance-critical code: eyeball the Core.
 535 writeBlocks :: Handle -> Bool -> Newline -> Buffer CharBufElem -> String -> IO ()
 536 writeBlocks hdl line_buffered nl
 537             buf@Buffer{ bufRaw=raw, bufSize=len } s =
 538   let
 539    shoveString :: Int -> [Char] -> IO ()
 540    shoveString !n [] = do
 541         _ <- commitBuffer hdl raw len n False{-no flush-} True{-release-}
 542         return ()
 543    shoveString !n (c:cs)
 544      -- n+1 so we have enough room to write '\r\n' if necessary
 545      | n + 1 >= len = do
 546         new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
 547         writeBlocks hdl line_buffered nl new_buf (c:cs)
 548      | c == '\n'  =  do
 549         n' <- if nl == CRLF
 550                  then do
 551                     n1 <- writeCharBuf raw n  '\r'
 552                     writeCharBuf raw n1 '\n'
 553                  else do
 554                     writeCharBuf raw n c
 555         if line_buffered
 556            then do
 557                new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
 558                writeBlocks hdl line_buffered nl new_buf cs
 559            else do
 560                shoveString n' cs
 561      | otherwise = do
 562         n' <- writeCharBuf raw n c
 563         shoveString n' cs
 564   in
 565   shoveString 0 s
 566
 567 -- -----------------------------------------------------------------------------
 568 -- commitBuffer handle buf sz count flush release
 569 --
 570 -- Write the contents of the buffer 'buf' ('sz' bytes long, containing
 571 -- 'count' bytes of data) to handle (handle must be block or line buffered).
 572 --
 573 -- Implementation:
 574 --
 575 --    for block/line buffering,
 576 --       1. If there isn't room in the handle buffer, flush the handle
 577 --          buffer.
 578 --
 579 --       2. If the handle buffer is empty,
 580 --               if flush,
 581 --                   then write buf directly to the device.
 582 --                   else swap the handle buffer with buf.
 583 --
 584 --       3. If the handle buffer is non-empty, copy buf into the
 585 --          handle buffer.  Then, if flush != 0, flush
 586 --          the buffer.
 587
 588 commitBuffer
 589         :: Handle                       -- handle to commit to
 590         -> RawCharBuffer -> Int         -- address and size (in bytes) of buffer
 591         -> Int                          -- number of bytes of data in buffer
 592         -> Bool                         -- True <=> flush the handle afterward
 593         -> Bool                         -- release the buffer?
 594         -> IO CharBuffer
 595
 596 commitBuffer hdl !raw !sz !count flush release =
 597   wantWritableHandle "commitAndReleaseBuffer" hdl $
 598      commitBuffer' raw sz count flush release
 599 {-# NOINLINE commitBuffer #-}
 600
 601 -- Explicitly lambda-lift this function to subvert GHC's full laziness
 602 -- optimisations, which otherwise tends to float out subexpressions
 603 -- past the \handle, which is really a pessimisation in this case because
 604 -- that lambda is a one-shot lambda.
 605 --
 606 -- Don't forget to export the function, to stop it being inlined too
 607 -- (this appears to be better than NOINLINE, because the strictness
 608 -- analyser still gets to worker-wrapper it).
 609 --
 610 -- This hack is a fairly big win for hPutStr performance.  --SDM 18/9/2001
 611 --
 612 commitBuffer' :: RawCharBuffer -> Int -> Int -> Bool -> Bool -> Handle__
 613               -> IO CharBuffer
 614 commitBuffer' raw sz@(I# _) count@(I# _) flush release
 615   handle_@Handle__{ haCharBuffer=ref, haBuffers=spare_buf_ref } = do
 616
 617       debugIO ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
 618             ++ ", flush=" ++ show flush ++ ", release=" ++ show release)
 619
 620       old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
 621           <- readIORef ref
 622
 623       buf_ret <-
 624         -- enough room in handle buffer?
 625          if (not flush && (size - w > count))
 626                 -- The > is to be sure that we never exactly fill
 627                 -- up the buffer, which would require a flush.  So
 628                 -- if copying the new data into the buffer would
 629                 -- make the buffer full, we just flush the existing
 630                 -- buffer and the new data immediately, rather than
 631                 -- copying before flushing.
 632
 633                 -- not flushing, and there's enough room in the buffer:
 634                 -- just copy the data in and update bufR.
 635             then do withRawBuffer raw     $ \praw ->
 636                       copyToRawBuffer old_raw (w*charSize)
 637                                       praw (fromIntegral (count*charSize))
 638                     writeIORef ref old_buf{ bufR = w + count }
 639                     return (emptyBuffer raw sz WriteBuffer)
 640
 641                 -- else, we have to flush
 642             else do flushed_buf <- flushWriteBuffer_ handle_ old_buf
 643
 644                     let this_buf =
 645                             Buffer{ bufRaw=raw, bufState=WriteBuffer,
 646                                     bufL=0, bufR=count, bufSize=sz }
 647
 648                         -- if:  (a) we don't have to flush, and
 649                         --      (b) size(new buffer) == size(old buffer), and
 650                         --      (c) new buffer is not full,
 651                         -- we can just just swap them over...
 652                     if (not flush && sz == size && count /= sz)
 653                         then do
 654                           writeIORef ref this_buf
 655                           return flushed_buf
 656
 657                         -- otherwise, we have to flush the new data too,
 658                         -- and start with a fresh buffer
 659                         else do
 660                           -- We're aren't going to use this buffer again
 661                           -- so we ignore the result of flushWriteBuffer_
 662                           _ <- flushWriteBuffer_ handle_ this_buf
 663                           writeIORef ref flushed_buf
 664                             -- if the sizes were different, then allocate
 665                             -- a new buffer of the correct size.
 666                           if sz == size
 667                              then return (emptyBuffer raw sz WriteBuffer)
 668                              else newCharBuffer size WriteBuffer
 669
 670       -- release the buffer if necessary
 671       case buf_ret of
 672         Buffer{ bufSize=buf_ret_sz, bufRaw=buf_ret_raw } -> do
 673           if release && buf_ret_sz == size
 674             then do
 675               spare_bufs <- readIORef spare_buf_ref
 676               writeIORef spare_buf_ref
 677                 (BufferListCons buf_ret_raw spare_bufs)
 678               return buf_ret
 679             else
 680               return buf_ret
 681
 682 -- ---------------------------------------------------------------------------
 683 -- Reading/writing sequences of bytes.
 684
 685 -- ---------------------------------------------------------------------------
 686 -- hPutBuf
 687
 688 -- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the
 689 -- buffer @buf@ to the handle @hdl@.  It returns ().
 690 --
 691 -- 'hPutBuf' ignores any text encoding that applies to the 'Handle',
 692 -- writing the bytes directly to the underlying file or device.
 693 --
 694 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
 695 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
 696 --
 697 -- This operation may fail with:
 698 --
 699 --  * 'ResourceVanished' if the handle is a pipe or socket, and the
 700 --    reading end is closed.  (If this is a POSIX system, and the program
 701 --    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 702 --    instead, whose default action is to terminate the program).
 703
 704 hPutBuf :: Handle                       -- handle to write to
 705         -> Ptr a                        -- address of buffer
 706         -> Int                          -- number of bytes of data in buffer
 707         -> IO ()
 708 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
 709                          return ()
 710
 711 hPutBufNonBlocking
 712         :: Handle                       -- handle to write to
 713         -> Ptr a                        -- address of buffer
 714         -> Int                          -- number of bytes of data in buffer
 715         -> IO Int                       -- returns: number of bytes written
 716 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
 717
 718 hPutBuf':: Handle                       -- handle to write to
 719         -> Ptr a                        -- address of buffer
 720         -> Int                          -- number of bytes of data in buffer
 721         -> Bool                         -- allow blocking?
 722         -> IO Int
 723 hPutBuf' handle ptr count can_block
 724   | count == 0 = return 0
 725   | count <  0 = illegalBufferSize handle "hPutBuf" count
 726   | otherwise =
 727     wantWritableHandle "hPutBuf" handle $
 728       \ h_@Handle__{..} -> do
 729           debugIO ("hPutBuf count=" ++ show count)
 730           -- first flush the Char buffer if it is non-empty, then we
 731           -- can work directly with the byte buffer
 732           cbuf <- readIORef haCharBuffer
 733           when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
 734
 735           r <- bufWrite h_ (castPtr ptr) count can_block
 736
 737           -- we must flush if this Handle is set to NoBuffering.  If
 738           -- it is set to LineBuffering, be conservative and flush
 739           -- anyway (we didn't check for newlines in the data).
 740           case haBufferMode of
 741              BlockBuffering _      -> do return ()
 742              _line_or_no_buffering -> do flushWriteBuffer h_
 743           return r
 744
 745 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
 746 bufWrite h_@Handle__{..} ptr count can_block =
 747   seq count $ do  -- strictness hack
 748   old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
 749      <- readIORef haByteBuffer
 750
 751   -- enough room in handle buffer?
 752   if (size - w > count)
 753         -- There's enough room in the buffer:
 754         -- just copy the data in and update bufR.
 755         then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
 756                 copyToRawBuffer old_raw w ptr (fromIntegral count)
 757                 writeIORef haByteBuffer old_buf{ bufR = w + count }
 758                 return count
 759
 760         -- else, we have to flush
 761         else do debugIO "hPutBuf: flushing first"
 762                 old_buf' <- Buffered.flushWriteBuffer haDevice old_buf
 763                         -- TODO: we should do a non-blocking flush here
 764                 writeIORef haByteBuffer old_buf'
 765                 -- if we can fit in the buffer, then just loop
 766                 if count < size
 767                    then bufWrite h_ ptr count can_block
 768                    else if can_block
 769                            then do writeChunk h_ (castPtr ptr) count
 770                                    return count
 771                            else writeChunkNonBlocking h_ (castPtr ptr) count
 772
 773 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
 774 writeChunk h_@Handle__{..} ptr bytes
 775   | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
 776   | otherwise = error "Todo: hPutBuf"
 777
 778 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
 779 writeChunkNonBlocking h_@Handle__{..} ptr bytes
 780   | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
 781   | otherwise = error "Todo: hPutBuf"
 782
 783 -- ---------------------------------------------------------------------------
 784 -- hGetBuf
 785
 786 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
 787 -- into the buffer @buf@ until either EOF is reached or
 788 -- @count@ 8-bit bytes have been read.
 789 -- It returns the number of bytes actually read.  This may be zero if
 790 -- EOF was reached before any data was read (or if @count@ is zero).
 791 --
 792 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
 793 -- using, and reads bytes directly from the underlying IO device.
 794 --
 795 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
 796 -- smaller than @count@.
 797 --
 798 -- If the handle is a pipe or socket, and the writing end
 799 -- is closed, 'hGetBuf' will behave as if EOF was reached.
 800 --
 801 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
 802 -- on the 'Handle', and reads bytes directly.
 803
 804 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 805 hGetBuf h ptr count
 806   | count == 0 = return 0
 807   | count <  0 = illegalBufferSize h "hGetBuf" count
 808   | otherwise =
 809       wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
 810          flushCharReadBuffer h_
 811          bufRead h_ (castPtr ptr) 0 count
 812
 813 -- small reads go through the buffer, large reads are satisfied by
 814 -- taking data first from the buffer and then direct from the file
 815 -- descriptor.
 816 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
 817 bufRead h_@Handle__{..} ptr so_far count =
 818   seq so_far $ seq count $ do -- strictness hack
 819   buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
 820   if isEmptyBuffer buf
 821      then if count > sz  -- small read?
 822                 then do rest <- readChunk h_ ptr count
 823                         return (so_far + rest)
 824                 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
 825                         if r == 0
 826                            then return so_far
 827                            else do writeIORef haByteBuffer buf'
 828                                    bufRead h_ ptr so_far count
 829      else do
 830         let avail = w - r
 831         if (count == avail)
 832            then do
 833                 copyFromRawBuffer ptr raw r count
 834                 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 835                 return (so_far + count)
 836            else do
 837         if (count < avail)
 838            then do
 839                 copyFromRawBuffer ptr raw r count
 840                 writeIORef haByteBuffer buf{ bufL = r + count }
 841                 return (so_far + count)
 842            else do
 843
 844         copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
 845         writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 846         let remaining = count - avail
 847             so_far' = so_far + avail
 848             ptr' = ptr `plusPtr` avail
 849
 850         if remaining < sz
 851            then bufRead h_ ptr' so_far' remaining
 852            else do
 853
 854         rest <- readChunk h_ ptr' remaining
 855         return (so_far' + rest)
 856
 857 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
 858 readChunk h_@Handle__{..} ptr bytes
 859  | Just fd <- cast haDevice = loop fd 0 bytes
 860  | otherwise = error "ToDo: hGetBuf"
 861  where
 862   loop :: FD -> Int -> Int -> IO Int
 863   loop fd off bytes | bytes <= 0 = return off
 864   loop fd off bytes = do
 865     r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
 866     if r == 0
 867         then return off
 868         else loop fd (off + r) (bytes - r)
 869
 870 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
 871 -- into the buffer @buf@ until either EOF is reached, or
 872 -- @count@ 8-bit bytes have been read, or there is no more data available
 873 -- to read immediately.
 874 --
 875 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
 876 -- never block waiting for data to become available, instead it returns
 877 -- only whatever data is available.  To wait for data to arrive before
 878 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
 879 --
 880 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
 881 -- is currently using, and reads bytes directly from the underlying IO
 882 -- device.
 883 --
 884 -- If the handle is a pipe or socket, and the writing end
 885 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
 886 --
 887 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
 888 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
 889
 890 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
 891 hGetBufNonBlocking h ptr count
 892   | count == 0 = return 0
 893   | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
 894   | otherwise =
 895       wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
 896          flushCharReadBuffer h_
 897          bufReadNonBlocking h_ (castPtr ptr) 0 count
 898
 899 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
 900 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
 901   seq so_far $ seq count $ do -- strictness hack
 902   buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
 903   if isEmptyBuffer buf
 904      then if count > sz  -- large read?
 905                 then do rest <- readChunkNonBlocking h_ ptr count
 906                         return (so_far + rest)
 907                 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
 908                         case r of
 909                           Nothing -> return so_far
 910                           Just 0  -> return so_far
 911                           Just r  -> do
 912                             writeIORef haByteBuffer buf'
 913                             bufReadNonBlocking h_ ptr so_far (min count r)
 914                                   -- NOTE: new count is    min count w'
 915                                   -- so we will just copy the contents of the
 916                                   -- buffer in the recursive call, and not
 917                                   -- loop again.
 918      else do
 919         let avail = w - r
 920         if (count == avail)
 921            then do
 922                 copyFromRawBuffer ptr raw r count
 923                 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 924                 return (so_far + count)
 925            else do
 926         if (count < avail)
 927            then do
 928                 copyFromRawBuffer ptr raw r count
 929                 writeIORef haByteBuffer buf{ bufL = r + count }
 930                 return (so_far + count)
 931            else do
 932
 933         copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
 934         writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 935         let remaining = count - avail
 936             so_far' = so_far + avail
 937             ptr' = ptr `plusPtr` avail
 938
 939         -- we haven't attempted to read anything yet if we get to here.
 940         if remaining < sz
 941            then bufReadNonBlocking h_ ptr' so_far' remaining
 942            else do
 943
 944         rest <- readChunkNonBlocking h_ ptr' remaining
 945         return (so_far' + rest)
 946
 947
 948 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
 949 readChunkNonBlocking h_@Handle__{..} ptr bytes
 950  | Just fd <- cast haDevice = do
 951      m <- RawIO.readNonBlocking (fd::FD) ptr bytes
 952      case m of
 953        Nothing -> return 0
 954        Just n  -> return n
 955  | otherwise = error "ToDo: hGetBuf"
 956
 957 -- ---------------------------------------------------------------------------
 958 -- memcpy wrappers
 959
 960 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
 961 copyToRawBuffer raw off ptr bytes =
 962  withRawBuffer raw $ \praw ->
 963    do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
 964       return ()
 965
 966 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
 967 copyFromRawBuffer ptr raw off bytes =
 968  withRawBuffer raw $ \praw ->
 969    do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
 970       return ()
 971
 972 foreign import ccall unsafe "memcpy"
 973    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
 974
 975 -----------------------------------------------------------------------------
 976 -- Internal Utils
 977
 978 illegalBufferSize :: Handle -> String -> Int -> IO a
 979 illegalBufferSize handle fn sz =
 980         ioException (IOError (Just handle)
 981                             InvalidArgument  fn
 982                             ("illegal buffer size " ++ showsPrec 9 sz [])
 983                             Nothing Nothing)