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