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