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