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 -- 'hPutBuf' ignores the prevailing 'TextEncoding' and
 684 -- 'NewlineMode' on the 'Handle', and writes bytes directly.
 685 --
 686 -- This operation may fail with:
 687 --
 688 --  * 'ResourceVanished' if the handle is a pipe or socket, and the
 689 --    reading end is closed.  (If this is a POSIX system, and the program
 690 --    has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered
 691 --    instead, whose default action is to terminate the program).
 692
 693 hPutBuf :: Handle                       -- handle to write to
 694         -> Ptr a                        -- address of buffer
 695         -> Int                          -- number of bytes of data in buffer
 696         -> IO ()
 697 hPutBuf h ptr count = do _ <- hPutBuf' h ptr count True
 698                          return ()
 699
 700 hPutBufNonBlocking
 701         :: Handle                       -- handle to write to
 702         -> Ptr a                        -- address of buffer
 703         -> Int                          -- number of bytes of data in buffer
 704         -> IO Int                       -- returns: number of bytes written
 705 hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False
 706
 707 hPutBuf':: Handle                       -- handle to write to
 708         -> Ptr a                        -- address of buffer
 709         -> Int                          -- number of bytes of data in buffer
 710         -> Bool                         -- allow blocking?
 711         -> IO Int
 712 hPutBuf' handle ptr count can_block
 713   | count == 0 = return 0
 714   | count <  0 = illegalBufferSize handle "hPutBuf" count
 715   | otherwise =
 716     wantWritableHandle "hPutBuf" handle $
 717       \ h_@Handle__{..} -> do
 718           debugIO ("hPutBuf count=" ++ show count)
 719           -- first flush the Char buffer if it is non-empty, then we
 720           -- can work directly with the byte buffer
 721           cbuf <- readIORef haCharBuffer
 722           when (not (isEmptyBuffer cbuf)) $ flushWriteBuffer h_
 723
 724           r <- bufWrite h_ (castPtr ptr) count can_block
 725
 726           -- we must flush if this Handle is set to NoBuffering.  If
 727           -- it is set to LineBuffering, be conservative and flush
 728           -- anyway (we didn't check for newlines in the data).
 729           case haBufferMode of
 730              BlockBuffering _      -> do return ()
 731              _line_or_no_buffering -> do flushWriteBuffer h_
 732           return r
 733
 734 bufWrite :: Handle__-> Ptr Word8 -> Int -> Bool -> IO Int
 735 bufWrite h_@Handle__{..} ptr count can_block =
 736   seq count $ do  -- strictness hack
 737   old_buf@Buffer{ bufRaw=old_raw, bufR=w, bufSize=size }
 738      <- readIORef haByteBuffer
 739
 740   -- enough room in handle buffer?
 741   if (size - w > count)
 742         -- There's enough room in the buffer:
 743         -- just copy the data in and update bufR.
 744         then do debugIO ("hPutBuf: copying to buffer, w=" ++ show w)
 745                 copyToRawBuffer old_raw w ptr (fromIntegral count)
 746                 writeIORef haByteBuffer old_buf{ bufR = w + count }
 747                 return count
 748
 749         -- else, we have to flush
 750         else do debugIO "hPutBuf: flushing first"
 751                 Buffered.flushWriteBuffer haDevice old_buf
 752                         -- TODO: we should do a non-blocking flush here
 753                 writeIORef haByteBuffer old_buf{bufL=0,bufR=0}
 754                 -- if we can fit in the buffer, then just loop
 755                 if count < size
 756                    then bufWrite h_ ptr count can_block
 757                    else if can_block
 758                            then do writeChunk h_ (castPtr ptr) count
 759                                    return count
 760                            else writeChunkNonBlocking h_ (castPtr ptr) count
 761
 762 writeChunk :: Handle__ -> Ptr Word8 -> Int -> IO ()
 763 writeChunk h_@Handle__{..} ptr bytes
 764   | Just fd <- cast haDevice  =  RawIO.write (fd::FD) ptr bytes
 765   | otherwise = error "Todo: hPutBuf"
 766
 767 writeChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
 768 writeChunkNonBlocking h_@Handle__{..} ptr bytes
 769   | Just fd <- cast haDevice  =  RawIO.writeNonBlocking (fd::FD) ptr bytes
 770   | otherwise = error "Todo: hPutBuf"
 771
 772 -- ---------------------------------------------------------------------------
 773 -- hGetBuf
 774
 775 -- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@
 776 -- into the buffer @buf@ until either EOF is reached or
 777 -- @count@ 8-bit bytes have been read.
 778 -- It returns the number of bytes actually read.  This may be zero if
 779 -- EOF was reached before any data was read (or if @count@ is zero).
 780 --
 781 -- 'hGetBuf' ignores whatever 'TextEncoding' the 'Handle' is currently
 782 -- using, and reads bytes directly from the underlying IO device.
 783 --
 784 -- 'hGetBuf' never raises an EOF exception, instead it returns a value
 785 -- smaller than @count@.
 786 --
 787 -- If the handle is a pipe or socket, and the writing end
 788 -- is closed, 'hGetBuf' will behave as if EOF was reached.
 789 --
 790 -- 'hGetBuf' ignores the prevailing 'TextEncoding' and 'NewlineMode'
 791 -- on the 'Handle', and reads bytes directly.
 792
 793 hGetBuf :: Handle -> Ptr a -> Int -> IO Int
 794 hGetBuf h ptr count
 795   | count == 0 = return 0
 796   | count <  0 = illegalBufferSize h "hGetBuf" count
 797   | otherwise =
 798       wantReadableHandle_ "hGetBuf" h $ \ h_ -> do
 799          flushCharReadBuffer h_
 800          bufRead h_ (castPtr ptr) 0 count
 801
 802 -- small reads go through the buffer, large reads are satisfied by
 803 -- taking data first from the buffer and then direct from the file
 804 -- descriptor.
 805 bufRead :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
 806 bufRead h_@Handle__{..} ptr so_far count =
 807   seq so_far $ seq count $ do -- strictness hack
 808   buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
 809   if isEmptyBuffer buf
 810      then if count > sz  -- small read?
 811                 then do rest <- readChunk h_ ptr count
 812                         return (so_far + rest)
 813                 else do (r,buf') <- Buffered.fillReadBuffer haDevice buf
 814                         if r == 0
 815                            then return so_far
 816                            else do writeIORef haByteBuffer buf'
 817                                    bufRead h_ ptr so_far count
 818      else do
 819         let avail = w - r
 820         if (count == avail)
 821            then do
 822                 copyFromRawBuffer ptr raw r count
 823                 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 824                 return (so_far + count)
 825            else do
 826         if (count < avail)
 827            then do
 828                 copyFromRawBuffer ptr raw r count
 829                 writeIORef haByteBuffer buf{ bufL = r + count }
 830                 return (so_far + count)
 831            else do
 832
 833         copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
 834         writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 835         let remaining = count - avail
 836             so_far' = so_far + avail
 837             ptr' = ptr `plusPtr` avail
 838
 839         if remaining < sz
 840            then bufRead h_ ptr' so_far' remaining
 841            else do
 842
 843         rest <- readChunk h_ ptr' remaining
 844         return (so_far' + rest)
 845
 846 readChunk :: Handle__ -> Ptr a -> Int -> IO Int
 847 readChunk h_@Handle__{..} ptr bytes
 848  | Just fd <- cast haDevice = loop fd 0 bytes
 849  | otherwise = error "ToDo: hGetBuf"
 850  where
 851   loop :: FD -> Int -> Int -> IO Int
 852   loop fd off bytes | bytes <= 0 = return off
 853   loop fd off bytes = do
 854     r <- RawIO.read (fd::FD) (ptr `plusPtr` off) (fromIntegral bytes)
 855     if r == 0
 856         then return off
 857         else loop fd (off + r) (bytes - r)
 858
 859 -- | 'hGetBufNonBlocking' @hdl buf count@ reads data from the handle @hdl@
 860 -- into the buffer @buf@ until either EOF is reached, or
 861 -- @count@ 8-bit bytes have been read, or there is no more data available
 862 -- to read immediately.
 863 --
 864 -- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will
 865 -- never block waiting for data to become available, instead it returns
 866 -- only whatever data is available.  To wait for data to arrive before
 867 -- calling 'hGetBufNonBlocking', use 'hWaitForInput'.
 868 --
 869 -- 'hGetBufNonBlocking' ignores whatever 'TextEncoding' the 'Handle'
 870 -- is currently using, and reads bytes directly from the underlying IO
 871 -- device.
 872 --
 873 -- If the handle is a pipe or socket, and the writing end
 874 -- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached.
 875 --
 876 -- 'hGetBufNonBlocking' ignores the prevailing 'TextEncoding' and
 877 -- 'NewlineMode' on the 'Handle', and reads bytes directly.
 878
 879 hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int
 880 hGetBufNonBlocking h ptr count
 881   | count == 0 = return 0
 882   | count <  0 = illegalBufferSize h "hGetBufNonBlocking" count
 883   | otherwise =
 884       wantReadableHandle_ "hGetBufNonBlocking" h $ \ h_ -> do
 885          flushCharReadBuffer h_
 886          bufReadNonBlocking h_ (castPtr ptr) 0 count
 887
 888 bufReadNonBlocking :: Handle__ -> Ptr Word8 -> Int -> Int -> IO Int
 889 bufReadNonBlocking h_@Handle__{..} ptr so_far count =
 890   seq so_far $ seq count $ do -- strictness hack
 891   buf@Buffer{ bufRaw=raw, bufR=w, bufL=r, bufSize=sz } <- readIORef haByteBuffer
 892   if isEmptyBuffer buf
 893      then if count > sz  -- large read?
 894                 then do rest <- readChunkNonBlocking h_ ptr count
 895                         return (so_far + rest)
 896                 else do (r,buf') <- Buffered.fillReadBuffer0 haDevice buf
 897                         case r of
 898                           Nothing -> return so_far
 899                           Just 0  -> return so_far
 900                           Just r  -> do
 901                             writeIORef haByteBuffer buf'
 902                             bufReadNonBlocking h_ ptr so_far (min count r)
 903                                   -- NOTE: new count is    min count w'
 904                                   -- so we will just copy the contents of the
 905                                   -- buffer in the recursive call, and not
 906                                   -- loop again.
 907      else do
 908         let avail = w - r
 909         if (count == avail)
 910            then do
 911                 copyFromRawBuffer ptr raw r count
 912                 writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 913                 return (so_far + count)
 914            else do
 915         if (count < avail)
 916            then do
 917                 copyFromRawBuffer ptr raw r count
 918                 writeIORef haByteBuffer buf{ bufL = r + count }
 919                 return (so_far + count)
 920            else do
 921
 922         copyFromRawBuffer ptr raw (fromIntegral r) (fromIntegral avail)
 923         writeIORef haByteBuffer buf{ bufR=0, bufL=0 }
 924         let remaining = count - avail
 925             so_far' = so_far + avail
 926             ptr' = ptr `plusPtr` avail
 927
 928         -- we haven't attempted to read anything yet if we get to here.
 929         if remaining < sz
 930            then bufReadNonBlocking h_ ptr' so_far' remaining
 931            else do
 932
 933         rest <- readChunkNonBlocking h_ ptr' remaining
 934         return (so_far' + rest)
 935
 936
 937 readChunkNonBlocking :: Handle__ -> Ptr Word8 -> Int -> IO Int
 938 readChunkNonBlocking h_@Handle__{..} ptr bytes
 939  | Just fd <- cast haDevice = do
 940      m <- RawIO.readNonBlocking (fd::FD) ptr bytes
 941      case m of
 942        Nothing -> return 0
 943        Just n  -> return n
 944  | otherwise = error "ToDo: hGetBuf"
 945
 946 -- ---------------------------------------------------------------------------
 947 -- memcpy wrappers
 948
 949 copyToRawBuffer :: RawBuffer e -> Int -> Ptr e -> Int -> IO ()
 950 copyToRawBuffer raw off ptr bytes =
 951  withRawBuffer raw $ \praw ->
 952    do _ <- memcpy (praw `plusPtr` off) ptr (fromIntegral bytes)
 953       return ()
 954
 955 copyFromRawBuffer :: Ptr e -> RawBuffer e -> Int -> Int -> IO ()
 956 copyFromRawBuffer ptr raw off bytes =
 957  withRawBuffer raw $ \praw ->
 958    do _ <- memcpy ptr (praw `plusPtr` off) (fromIntegral bytes)
 959       return ()
 960
 961 foreign import ccall unsafe "memcpy"
 962    memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr ())
 963
 964 -----------------------------------------------------------------------------
 965 -- Internal Utils
 966
 967 illegalBufferSize :: Handle -> String -> Int -> IO a
 968 illegalBufferSize handle fn sz =
 969         ioException (IOError (Just handle)
 970                             InvalidArgument  fn
 971                             ("illegal buffer size " ++ showsPrec 9 sz [])
 972                             Nothing Nothing)