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