GHC/IO/Handle/Text.hs

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