GHC/IO/Handle/Text.hs

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