GHC/IO/Handle/Internals.hs

   1 {-# LANGUAGE NoImplicitPrelude
   2            , RecordWildCards
   3            , BangPatterns
   4            , PatternGuards
   5            , NondecreasingIndentation
   6            , Rank2Types
   7   #-}
   8 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
   9 {-# OPTIONS_GHC -fno-warn-name-shadowing #-}
  10 {-# OPTIONS_HADDOCK hide #-}
  11
  12 -----------------------------------------------------------------------------
  13 -- |
  14 -- Module      :  GHC.IO.Handle.Internals
  15 -- Copyright   :  (c) The University of Glasgow, 1994-2001
  16 -- License     :  see libraries/base/LICENSE
  17 --
  18 -- Maintainer  :  libraries@haskell.org
  19 -- Stability   :  internal
  20 -- Portability :  non-portable
  21 --
  22 -- This module defines the basic operations on I\/O \"handles\".  All
  23 -- of the operations defined here are independent of the underlying
  24 -- device.
  25 --
  26 -----------------------------------------------------------------------------
  27
  28 -- #hide
  29 module GHC.IO.Handle.Internals (
  30   withHandle, withHandle', withHandle_,
  31   withHandle__', withHandle_', withAllHandles__,
  32   wantWritableHandle, wantReadableHandle, wantReadableHandle_,
  33   wantSeekableHandle,
  34
  35   mkHandle, mkFileHandle, mkDuplexHandle,
  36   openTextEncoding, closeTextCodecs, initBufferState,
  37   dEFAULT_CHAR_BUFFER_SIZE,
  38
  39   flushBuffer, flushWriteBuffer, flushCharReadBuffer,
  40   flushCharBuffer, flushByteReadBuffer, flushByteWriteBuffer,
  41
  42   readTextDevice, writeCharBuffer, readTextDeviceNonBlocking,
  43   decodeByteBuf,
  44
  45   augmentIOError,
  46   ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
  47   ioe_finalizedHandle, ioe_bufsiz,
  48
  49   hClose_help, hLookAhead_,
  50
  51   HandleFinalizer, handleFinalizer,
  52
  53   debugIO,
  54  ) where
  55
  56 import GHC.IO
  57 import GHC.IO.IOMode
  58 import GHC.IO.Encoding as Encoding
  59 import GHC.IO.Handle.Types
  60 import GHC.IO.Buffer
  61 import GHC.IO.BufferedIO (BufferedIO)
  62 import GHC.IO.Exception
  63 import GHC.IO.Device (IODevice, SeekMode(..))
  64 import qualified GHC.IO.Device as IODevice
  65 import qualified GHC.IO.BufferedIO as Buffered
  66
  67 import GHC.Conc.Sync
  68 import GHC.Real
  69 import GHC.Base
  70 import GHC.Exception
  71 import GHC.Num          ( Num(..) )
  72 import GHC.Show
  73 import GHC.IORef
  74 import GHC.MVar
  75 import Data.Typeable
  76 import Control.Monad
  77 import Data.Maybe
  78 import Foreign hiding (unsafePerformIO)
  79 -- import System.IO.Error
  80 import System.Posix.Internals hiding (FD)
  81
  82 import Foreign.C
  83
  84 c_DEBUG_DUMP :: Bool
  85 c_DEBUG_DUMP = False
  86
  87 -- ---------------------------------------------------------------------------
  88 -- Creating a new handle
  89
  90 type HandleFinalizer = FilePath -> MVar Handle__ -> IO ()
  91
  92 newFileHandle :: FilePath -> Maybe HandleFinalizer -> Handle__ -> IO Handle
  93 newFileHandle filepath mb_finalizer hc = do
  94   m <- newMVar hc
  95   case mb_finalizer of
  96     Just finalizer -> addMVarFinalizer m (finalizer filepath m)
  97     Nothing        -> return ()
  98   return (FileHandle filepath m)
  99
 100 -- ---------------------------------------------------------------------------
 101 -- Working with Handles
 102
 103 {-
 104 In the concurrent world, handles are locked during use.  This is done
 105 by wrapping an MVar around the handle which acts as a mutex over
 106 operations on the handle.
 107
 108 To avoid races, we use the following bracketing operations.  The idea
 109 is to obtain the lock, do some operation and replace the lock again,
 110 whether the operation succeeded or failed.  We also want to handle the
 111 case where the thread receives an exception while processing the IO
 112 operation: in these cases we also want to relinquish the lock.
 113
 114 There are three versions of @withHandle@: corresponding to the three
 115 possible combinations of:
 116
 117         - the operation may side-effect the handle
 118         - the operation may return a result
 119
 120 If the operation generates an error or an exception is raised, the
 121 original handle is always replaced.
 122 -}
 123
 124 {-# INLINE withHandle #-}
 125 withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 126 withHandle fun h@(FileHandle _ m)     act = withHandle' fun h m act
 127 withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act
 128
 129 withHandle' :: String -> Handle -> MVar Handle__
 130    -> (Handle__ -> IO (Handle__,a)) -> IO a
 131 withHandle' fun h m act =
 132  mask_ $ do
 133    (h',v)  <- do_operation fun h act m
 134    checkHandleInvariants h'
 135    putMVar m h'
 136    return v
 137
 138 {-# INLINE withHandle_ #-}
 139 withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
 140 withHandle_ fun h@(FileHandle _ m)     act = withHandle_' fun h m act
 141 withHandle_ fun h@(DuplexHandle _ m _) act = withHandle_' fun h m act
 142
 143 withHandle_' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO a) -> IO a
 144 withHandle_' fun h m act = withHandle' fun h m $ \h_ -> do
 145                               a <- act h_
 146                               return (h_,a)
 147
 148 withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO ()
 149 withAllHandles__ fun h@(FileHandle _ m)     act = withHandle__' fun h m act
 150 withAllHandles__ fun h@(DuplexHandle _ r w) act = do
 151   withHandle__' fun h r act
 152   withHandle__' fun h w act
 153
 154 withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__)
 155               -> IO ()
 156 withHandle__' fun h m act =
 157  mask_ $ do
 158    h'  <- do_operation fun h act m
 159    checkHandleInvariants h'
 160    putMVar m h'
 161    return ()
 162
 163 do_operation :: String -> Handle -> (Handle__ -> IO a) -> MVar Handle__ -> IO a
 164 do_operation fun h act m = do
 165   h_ <- takeMVar m
 166   checkHandleInvariants h_
 167   act h_ `catchException` handler h_
 168   where
 169     handler h_ e = do
 170       putMVar m h_
 171       case () of
 172         _ | Just ioe <- fromException e ->
 173             ioError (augmentIOError ioe fun h)
 174         _ | Just async_ex <- fromException e -> do -- see Note [async]
 175             let _ = async_ex :: AsyncException
 176             t <- myThreadId
 177             throwTo t e
 178             do_operation fun h act m
 179         _otherwise ->
 180             throwIO e
 181
 182 -- Note [async]
 183 --
 184 -- If an asynchronous exception is raised during an I/O operation,
 185 -- normally it is fine to just re-throw the exception synchronously.
 186 -- However, if we are inside an unsafePerformIO or an
 187 -- unsafeInterleaveIO, this would replace the enclosing thunk with the
 188 -- exception raised, which is wrong (#3997).  We have to release the
 189 -- lock on the Handle, but what do we replace the thunk with?  What
 190 -- should happen when the thunk is subsequently demanded again?
 191 --
 192 -- The only sensible choice we have is to re-do the IO operation on
 193 -- resumption, but then we have to be careful in the IO library that
 194 -- this is always safe to do.  In particular we should
 195 --
 196 --    never perform any side-effects before an interruptible operation
 197 --
 198 -- because the interruptible operation may raise an asynchronous
 199 -- exception, which may cause the operation and its side effects to be
 200 -- subsequently performed again.
 201 --
 202 -- Re-doing the IO operation is achieved by:
 203 --   - using throwTo to re-throw the asynchronous exception asynchronously
 204 --     in the current thread
 205 --   - on resumption, it will be as if throwTo returns.  In that case, we
 206 --     recursively invoke the original operation (see do_operation above).
 207 --
 208 -- Interruptible operations in the I/O library are:
 209 --    - threadWaitRead/threadWaitWrite
 210 --    - fillReadBuffer/flushWriteBuffer
 211 --    - readTextDevice/writeTextDevice
 212
 213 augmentIOError :: IOException -> String -> Handle -> IOException
 214 augmentIOError ioe@IOError{ ioe_filename = fp } fun h
 215   = ioe { ioe_handle = Just h, ioe_location = fun, ioe_filename = filepath }
 216   where filepath
 217           | Just _ <- fp = fp
 218           | otherwise = case h of
 219                           FileHandle path _     -> Just path
 220                           DuplexHandle path _ _ -> Just path
 221
 222 -- ---------------------------------------------------------------------------
 223 -- Wrapper for write operations.
 224
 225 wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 226 wantWritableHandle fun h@(FileHandle _ m) act
 227   = wantWritableHandle' fun h m act
 228 wantWritableHandle fun h@(DuplexHandle _ _ m) act
 229   = wantWritableHandle' fun h m act
 230     -- we know it's not a ReadHandle or ReadWriteHandle, but we have to
 231     -- check for ClosedHandle/SemiClosedHandle. (#4808)
 232
 233 wantWritableHandle'
 234         :: String -> Handle -> MVar Handle__
 235         -> (Handle__ -> IO a) -> IO a
 236 wantWritableHandle' fun h m act
 237    = withHandle_' fun h m (checkWritableHandle act)
 238
 239 checkWritableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
 240 checkWritableHandle act h_@Handle__{..}
 241   = case haType of
 242       ClosedHandle         -> ioe_closedHandle
 243       SemiClosedHandle     -> ioe_closedHandle
 244       ReadHandle           -> ioe_notWritable
 245       ReadWriteHandle      -> do
 246         buf <- readIORef haCharBuffer
 247         when (not (isWriteBuffer buf)) $ do
 248            flushCharReadBuffer h_
 249            flushByteReadBuffer h_
 250            buf <- readIORef haCharBuffer
 251            writeIORef haCharBuffer buf{ bufState = WriteBuffer }
 252            buf <- readIORef haByteBuffer
 253            buf' <- Buffered.emptyWriteBuffer haDevice buf
 254            writeIORef haByteBuffer buf'
 255         act h_
 256       _other               -> act h_
 257
 258 -- ---------------------------------------------------------------------------
 259 -- Wrapper for read operations.
 260
 261 wantReadableHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
 262 wantReadableHandle fun h act = withHandle fun h (checkReadableHandle act)
 263
 264 wantReadableHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a
 265 wantReadableHandle_ fun h@(FileHandle  _ m)   act
 266   = wantReadableHandle' fun h m act
 267 wantReadableHandle_ fun h@(DuplexHandle _ m _) act
 268   = wantReadableHandle' fun h m act
 269     -- we know it's not a WriteHandle or ReadWriteHandle, but we have to
 270     -- check for ClosedHandle/SemiClosedHandle. (#4808)
 271
 272 wantReadableHandle'
 273         :: String -> Handle -> MVar Handle__
 274         -> (Handle__ -> IO a) -> IO a
 275 wantReadableHandle' fun h m act
 276   = withHandle_' fun h m (checkReadableHandle act)
 277
 278 checkReadableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
 279 checkReadableHandle act h_@Handle__{..} =
 280     case haType of
 281       ClosedHandle         -> ioe_closedHandle
 282       SemiClosedHandle     -> ioe_closedHandle
 283       AppendHandle         -> ioe_notReadable
 284       WriteHandle          -> ioe_notReadable
 285       ReadWriteHandle      -> do
 286           -- a read/write handle and we want to read from it.  We must
 287           -- flush all buffered write data first.
 288           bbuf <- readIORef haByteBuffer
 289           when (isWriteBuffer bbuf) $ do
 290              when (not (isEmptyBuffer bbuf)) $ flushByteWriteBuffer h_
 291              cbuf' <- readIORef haCharBuffer
 292              writeIORef haCharBuffer cbuf'{ bufState = ReadBuffer }
 293              bbuf <- readIORef haByteBuffer
 294              writeIORef haByteBuffer bbuf{ bufState = ReadBuffer }
 295           act h_
 296       _other               -> act h_
 297
 298 -- ---------------------------------------------------------------------------
 299 -- Wrapper for seek operations.
 300
 301 wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
 302 wantSeekableHandle fun h@(DuplexHandle _ _ _) _act =
 303   ioException (IOError (Just h) IllegalOperation fun
 304                    "handle is not seekable" Nothing Nothing)
 305 wantSeekableHandle fun h@(FileHandle _ m) act =
 306   withHandle_' fun h m (checkSeekableHandle act)
 307
 308 checkSeekableHandle :: (Handle__ -> IO a) -> Handle__ -> IO a
 309 checkSeekableHandle act handle_@Handle__{haDevice=dev} =
 310     case haType handle_ of
 311       ClosedHandle      -> ioe_closedHandle
 312       SemiClosedHandle  -> ioe_closedHandle
 313       AppendHandle      -> ioe_notSeekable
 314       _ -> do b <- IODevice.isSeekable dev
 315               if b then act handle_
 316                    else ioe_notSeekable
 317
 318 -- -----------------------------------------------------------------------------
 319 -- Handy IOErrors
 320
 321 ioe_closedHandle, ioe_EOF,
 322   ioe_notReadable, ioe_notWritable, ioe_cannotFlushNotSeekable,
 323   ioe_notSeekable, ioe_invalidCharacter :: IO a
 324
 325 ioe_closedHandle = ioException
 326    (IOError Nothing IllegalOperation ""
 327         "handle is closed" Nothing Nothing)
 328 ioe_EOF = ioException
 329    (IOError Nothing EOF "" "" Nothing Nothing)
 330 ioe_notReadable = ioException
 331    (IOError Nothing IllegalOperation ""
 332         "handle is not open for reading" Nothing Nothing)
 333 ioe_notWritable = ioException
 334    (IOError Nothing IllegalOperation ""
 335         "handle is not open for writing" Nothing Nothing)
 336 ioe_notSeekable = ioException
 337    (IOError Nothing IllegalOperation ""
 338         "handle is not seekable" Nothing Nothing)
 339 ioe_cannotFlushNotSeekable = ioException
 340    (IOError Nothing IllegalOperation ""
 341       "cannot flush the read buffer: underlying device is not seekable"
 342         Nothing Nothing)
 343 ioe_invalidCharacter = ioException
 344    (IOError Nothing InvalidArgument ""
 345         ("invalid byte sequence for this encoding") Nothing Nothing)
 346
 347 ioe_finalizedHandle :: FilePath -> Handle__
 348 ioe_finalizedHandle fp = throw
 349    (IOError Nothing IllegalOperation ""
 350         "handle is finalized" Nothing (Just fp))
 351
 352 ioe_bufsiz :: Int -> IO a
 353 ioe_bufsiz n = ioException
 354    (IOError Nothing InvalidArgument "hSetBuffering"
 355         ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing)
 356                                 -- 9 => should be parens'ified.
 357
 358 -- ---------------------------------------------------------------------------
 359 -- Wrapper for Handle encoding/decoding.
 360
 361 -- The interface for TextEncoding changed so that a TextEncoding doesn't raise
 362 -- an exception if it encounters an invalid sequnce. Furthermore, encoding
 363 -- returns a reason as to why encoding stopped, letting us know if it was due
 364 -- to input/output underflow or an invalid sequence.
 365 --
 366 -- This code adapts this elaborated interface back to the original TextEncoding
 367 -- interface.
 368 --
 369 -- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields
 370 -- could be made clearer by using the 'encode' interface directly. I have not
 371 -- looked into this.
 372 --
 373 -- FIXME: we should use recover to deal with EOF, rather than always throwing an
 374 -- IOException (ioe_invalidCharacter).
 375
 376 streamEncode :: BufferCodec from to state
 377              -> Buffer from -> Buffer to
 378              -> IO (Buffer from, Buffer to)
 379 streamEncode codec from to = go (from, to)
 380   where
 381     go (from, to) = do
 382       (why, from', to') <- encode codec from to
 383       -- When we are dealing with Handles, we don't care about input/output
 384       -- underflow particularly, and we want to delay errors about invalid
 385       -- sequences as far as possible.
 386       case why of
 387         Encoding.InvalidSequence | bufL from == bufL from' -> recover codec from' to' >>= go
 388         _ -> return (from', to')
 389
 390 -- -----------------------------------------------------------------------------
 391 -- Handle Finalizers
 392
 393 -- For a duplex handle, we arrange that the read side points to the write side
 394 -- (and hence keeps it alive if the read side is alive).  This is done by
 395 -- having the haOtherSide field of the read side point to the read side.
 396 -- The finalizer is then placed on the write side, and the handle only gets
 397 -- finalized once, when both sides are no longer required.
 398
 399 -- NOTE about finalized handles: It's possible that a handle can be
 400 -- finalized and then we try to use it later, for example if the
 401 -- handle is referenced from another finalizer, or from a thread that
 402 -- has become unreferenced and then resurrected (arguably in the
 403 -- latter case we shouldn't finalize the Handle...).  Anyway,
 404 -- we try to emit a helpful message which is better than nothing.
 405 --
 406 -- [later; 8/2010] However, a program like this can yield a strange
 407 -- error message:
 408 --
 409 --   main = writeFile "out" loop
 410 --   loop = let x = x in x
 411 --
 412 -- because the main thread and the Handle are both unreachable at the
 413 -- same time, the Handle may get finalized before the main thread
 414 -- receives the NonTermination exception, and the exception handler
 415 -- will then report an error.  We'd rather this was not an error and
 416 -- the program just prints "<<loop>>".
 417
 418 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
 419 handleFinalizer fp m = do
 420   handle_ <- takeMVar m
 421   (handle_', _) <- hClose_help handle_
 422   putMVar m handle_'
 423   return ()
 424
 425 -- ---------------------------------------------------------------------------
 426 -- Allocating buffers
 427
 428 -- using an 8k char buffer instead of 32k improved performance for a
 429 -- basic "cat" program by ~30% for me.  --SDM
 430 dEFAULT_CHAR_BUFFER_SIZE :: Int
 431 dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar)
 432
 433 getCharBuffer :: IODevice dev => dev -> BufferState
 434               -> IO (IORef CharBuffer, BufferMode)
 435 getCharBuffer dev state = do
 436   buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 437   ioref  <- newIORef buffer
 438   is_tty <- IODevice.isTerminal dev
 439
 440   let buffer_mode
 441          | is_tty    = LineBuffering
 442          | otherwise = BlockBuffering Nothing
 443
 444   return (ioref, buffer_mode)
 445
 446 mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
 447 mkUnBuffer state = do
 448   buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 449               --  See [note Buffer Sizing], GHC.IO.Handle.Types
 450   ref <- newIORef buffer
 451   return (ref, NoBuffering)
 452
 453 -- -----------------------------------------------------------------------------
 454 -- Flushing buffers
 455
 456 -- | syncs the file with the buffer, including moving the
 457 -- file pointer backwards in the case of a read buffer.  This can fail
 458 -- on a non-seekable read Handle.
 459 flushBuffer :: Handle__ -> IO ()
 460 flushBuffer h_@Handle__{..} = do
 461   buf <- readIORef haCharBuffer
 462   case bufState buf of
 463     ReadBuffer  -> do
 464         flushCharReadBuffer h_
 465         flushByteReadBuffer h_
 466     WriteBuffer -> do
 467         flushByteWriteBuffer h_
 468
 469 -- | flushes the Char buffer only.  Works on all Handles.
 470 flushCharBuffer :: Handle__ -> IO ()
 471 flushCharBuffer h_@Handle__{..} = do
 472   cbuf <- readIORef haCharBuffer
 473   case bufState cbuf of
 474     ReadBuffer  -> do
 475         flushCharReadBuffer h_
 476     WriteBuffer ->
 477         when (not (isEmptyBuffer cbuf)) $
 478            error "internal IO library error: Char buffer non-empty"
 479
 480 -- -----------------------------------------------------------------------------
 481 -- Writing data (flushing write buffers)
 482
 483 -- flushWriteBuffer flushes the buffer iff it contains pending write
 484 -- data.  Flushes both the Char and the byte buffer, leaving both
 485 -- empty.
 486 flushWriteBuffer :: Handle__ -> IO ()
 487 flushWriteBuffer h_@Handle__{..} = do
 488   buf <- readIORef haByteBuffer
 489   when (isWriteBuffer buf) $ flushByteWriteBuffer h_
 490
 491 flushByteWriteBuffer :: Handle__ -> IO ()
 492 flushByteWriteBuffer h_@Handle__{..} = do
 493   bbuf <- readIORef haByteBuffer
 494   when (not (isEmptyBuffer bbuf)) $ do
 495     bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
 496     writeIORef haByteBuffer bbuf'
 497
 498 -- write the contents of the CharBuffer to the Handle__.
 499 -- The data will be encoded and pushed to the byte buffer,
 500 -- flushing if the buffer becomes full.
 501 writeCharBuffer :: Handle__ -> CharBuffer -> IO ()
 502 writeCharBuffer h_@Handle__{..} !cbuf = do
 503   --
 504   bbuf <- readIORef haByteBuffer
 505
 506   debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
 507         " bbuf=" ++ summaryBuffer bbuf)
 508
 509   (cbuf',bbuf') <- case haEncoder of
 510     Nothing      -> latin1_encode cbuf bbuf
 511     Just encoder -> (streamEncode encoder) cbuf bbuf
 512
 513   debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++
 514         " bbuf=" ++ summaryBuffer bbuf')
 515
 516           -- flush if the write buffer is full
 517   if isFullBuffer bbuf'
 518           --  or we made no progress
 519      || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf
 520           -- or the byte buffer has more elements than the user wanted buffered
 521      || (case haBufferMode of
 522           BlockBuffering (Just s) -> bufferElems bbuf' >= s
 523           NoBuffering -> True
 524           _other -> False)
 525     then do
 526       bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
 527       writeIORef haByteBuffer bbuf''
 528     else
 529       writeIORef haByteBuffer bbuf'
 530
 531   if not (isEmptyBuffer cbuf')
 532      then writeCharBuffer h_ cbuf'
 533      else return ()
 534
 535 -- -----------------------------------------------------------------------------
 536 -- Flushing read buffers
 537
 538 -- It is always possible to flush the Char buffer back to the byte buffer.
 539 flushCharReadBuffer :: Handle__ -> IO ()
 540 flushCharReadBuffer Handle__{..} = do
 541   cbuf <- readIORef haCharBuffer
 542   if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do
 543
 544   -- haLastDecode is the byte buffer just before we did our last batch of
 545   -- decoding.  We're going to re-decode the bytes up to the current char,
 546   -- to find out where we should revert the byte buffer to.
 547   (codec_state, bbuf0) <- readIORef haLastDecode
 548
 549   cbuf0 <- readIORef haCharBuffer
 550   writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
 551
 552   -- if we haven't used any characters from the char buffer, then just
 553   -- re-install the old byte buffer.
 554   if bufL cbuf0 == 0
 555      then do writeIORef haByteBuffer bbuf0
 556              return ()
 557      else do
 558
 559   case haDecoder of
 560     Nothing -> do
 561       writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
 562       -- no decoder: the number of bytes to decode is the same as the
 563       -- number of chars we have used up.
 564
 565     Just decoder -> do
 566       debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
 567                " cbuf=" ++ summaryBuffer cbuf0)
 568
 569       -- restore the codec state
 570       setState decoder codec_state
 571
 572       (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0
 573                                cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
 574
 575       debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
 576                " cbuf=" ++ summaryBuffer cbuf1)
 577
 578       writeIORef haByteBuffer bbuf1
 579
 580
 581 -- When flushing the byte read buffer, we seek backwards by the number
 582 -- of characters in the buffer.  The file descriptor must therefore be
 583 -- seekable: attempting to flush the read buffer on an unseekable
 584 -- handle is not allowed.
 585
 586 flushByteReadBuffer :: Handle__ -> IO ()
 587 flushByteReadBuffer h_@Handle__{..} = do
 588   bbuf <- readIORef haByteBuffer
 589
 590   if isEmptyBuffer bbuf then return () else do
 591
 592   seekable <- IODevice.isSeekable haDevice
 593   when (not seekable) $ ioe_cannotFlushNotSeekable
 594
 595   let seek = negate (bufR bbuf - bufL bbuf)
 596
 597   debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
 598   IODevice.seek haDevice RelativeSeek (fromIntegral seek)
 599
 600   writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }
 601
 602 -- ----------------------------------------------------------------------------
 603 -- Making Handles
 604
 605 mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 606             -> FilePath
 607             -> HandleType
 608             -> Bool                     -- buffered?
 609             -> Maybe TextEncoding
 610             -> NewlineMode
 611             -> Maybe HandleFinalizer
 612             -> Maybe (MVar Handle__)
 613             -> IO Handle
 614
 615 mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
 616    openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
 617
 618    let buf_state = initBufferState ha_type
 619    bbuf <- Buffered.newBuffer dev buf_state
 620    bbufref <- newIORef bbuf
 621    last_decode <- newIORef (error "codec_state", bbuf)
 622
 623    (cbufref,bmode) <-
 624          if buffered then getCharBuffer dev buf_state
 625                      else mkUnBuffer buf_state
 626
 627    spares <- newIORef BufferListNil
 628    newFileHandle filepath finalizer
 629             (Handle__ { haDevice = dev,
 630                         haType = ha_type,
 631                         haBufferMode = bmode,
 632                         haByteBuffer = bbufref,
 633                         haLastDecode = last_decode,
 634                         haCharBuffer = cbufref,
 635                         haBuffers = spares,
 636                         haEncoder = mb_encoder,
 637                         haDecoder = mb_decoder,
 638                         haCodec = mb_codec,
 639                         haInputNL = inputNL nl,
 640                         haOutputNL = outputNL nl,
 641                         haOtherSide = other_side
 642                       })
 643
 644 -- | makes a new 'Handle'
 645 mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
 646              => dev -- ^ the underlying IO device, which must support
 647                     -- 'IODevice', 'BufferedIO' and 'Typeable'
 648              -> FilePath
 649                     -- ^ a string describing the 'Handle', e.g. the file
 650                     -- path for a file.  Used in error messages.
 651              -> IOMode
 652                     -- The mode in which the 'Handle' is to be used
 653              -> Maybe TextEncoding
 654                     -- Create the 'Handle' with no text encoding?
 655              -> NewlineMode
 656                     -- Translate newlines?
 657              -> IO Handle
 658 mkFileHandle dev filepath iomode mb_codec tr_newlines = do
 659    mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
 660             tr_newlines
 661             (Just handleFinalizer) Nothing{-other_side-}
 662
 663 -- | like 'mkFileHandle', except that a 'Handle' is created with two
 664 -- independent buffers, one for reading and one for writing.  Used for
 665 -- full-duplex streams, such as network sockets.
 666 mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 667                -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
 668 mkDuplexHandle dev filepath mb_codec tr_newlines = do
 669
 670   write_side@(FileHandle _ write_m) <-
 671        mkHandle dev filepath WriteHandle True mb_codec
 672                         tr_newlines
 673                         (Just handleFinalizer)
 674                         Nothing -- no othersie
 675
 676   read_side@(FileHandle _ read_m) <-
 677       mkHandle dev filepath ReadHandle True mb_codec
 678                         tr_newlines
 679                         Nothing -- no finalizer
 680                         (Just write_m)
 681
 682   return (DuplexHandle filepath read_m write_m)
 683
 684 ioModeToHandleType :: IOMode -> HandleType
 685 ioModeToHandleType ReadMode      = ReadHandle
 686 ioModeToHandleType WriteMode     = WriteHandle
 687 ioModeToHandleType ReadWriteMode = ReadWriteHandle
 688 ioModeToHandleType AppendMode    = AppendHandle
 689
 690 initBufferState :: HandleType -> BufferState
 691 initBufferState ReadHandle = ReadBuffer
 692 initBufferState _          = WriteBuffer
 693
 694 openTextEncoding
 695    :: Maybe TextEncoding
 696    -> HandleType
 697    -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
 698    -> IO a
 699
 700 openTextEncoding Nothing   ha_type cont = cont Nothing Nothing
 701 openTextEncoding (Just TextEncoding{..}) ha_type cont = do
 702     mb_decoder <- if isReadableHandleType ha_type then do
 703                      decoder <- mkTextDecoder
 704                      return (Just decoder)
 705                   else
 706                      return Nothing
 707     mb_encoder <- if isWritableHandleType ha_type then do
 708                      encoder <- mkTextEncoder
 709                      return (Just encoder)
 710                   else
 711                      return Nothing
 712     cont mb_encoder mb_decoder
 713
 714 closeTextCodecs :: Handle__ -> IO ()
 715 closeTextCodecs Handle__{..} = do
 716   case haDecoder of Nothing -> return (); Just d -> Encoding.close d
 717   case haEncoder of Nothing -> return (); Just d -> Encoding.close d
 718
 719 -- ---------------------------------------------------------------------------
 720 -- closing Handles
 721
 722 -- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
 723 -- EOF is read or an IO error occurs on a lazy stream.  The
 724 -- semi-closed Handle is then closed immediately.  We have to be
 725 -- careful with DuplexHandles though: we have to leave the closing to
 726 -- the finalizer in that case, because the write side may still be in
 727 -- use.
 728 hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
 729 hClose_help handle_ =
 730   case haType handle_ of
 731       ClosedHandle -> return (handle_,Nothing)
 732       _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
 733                     -- it is important that hClose doesn't fail and
 734                     -- leave the Handle open (#3128), so we catch
 735                     -- exceptions when flushing the buffer.
 736               (h_, mb_exc2) <- hClose_handle_ handle_
 737               return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
 738
 739
 740 trymaybe :: IO () -> IO (Maybe SomeException)
 741 trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
 742
 743 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
 744 hClose_handle_ h_@Handle__{..} = do
 745
 746     -- close the file descriptor, but not when this is the read
 747     -- side of a duplex handle.
 748     -- If an exception is raised by the close(), we want to continue
 749     -- to close the handle and release the lock if it has one, then
 750     -- we return the exception to the caller of hClose_help which can
 751     -- raise it if necessary.
 752     maybe_exception <-
 753       case haOtherSide of
 754         Nothing -> trymaybe $ IODevice.close haDevice
 755         Just _  -> return Nothing
 756
 757     -- free the spare buffers
 758     writeIORef haBuffers BufferListNil
 759     writeIORef haCharBuffer noCharBuffer
 760     writeIORef haByteBuffer noByteBuffer
 761
 762     -- release our encoder/decoder
 763     closeTextCodecs h_
 764
 765     -- we must set the fd to -1, because the finalizer is going
 766     -- to run eventually and try to close/unlock it.
 767     -- ToDo: necessary?  the handle will be marked ClosedHandle
 768     -- XXX GHC won't let us use record update here, hence wildcards
 769     return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
 770
 771 {-# NOINLINE noCharBuffer #-}
 772 noCharBuffer :: CharBuffer
 773 noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
 774
 775 {-# NOINLINE noByteBuffer #-}
 776 noByteBuffer :: Buffer Word8
 777 noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
 778
 779 -- ---------------------------------------------------------------------------
 780 -- Looking ahead
 781
 782 hLookAhead_ :: Handle__ -> IO Char
 783 hLookAhead_ handle_@Handle__{..} = do
 784     buf <- readIORef haCharBuffer
 785
 786     -- fill up the read buffer if necessary
 787     new_buf <- if isEmptyBuffer buf
 788                   then readTextDevice handle_ buf
 789                   else return buf
 790     writeIORef haCharBuffer new_buf
 791
 792     peekCharBuf (bufRaw buf) (bufL buf)
 793
 794 -- ---------------------------------------------------------------------------
 795 -- debugging
 796
 797 debugIO :: String -> IO ()
 798 debugIO s
 799  | c_DEBUG_DUMP
 800     = do _ <- withCStringLen (s ++ "\n") $
 801                   \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
 802          return ()
 803  | otherwise = return ()
 804
 805 -- ----------------------------------------------------------------------------
 806 -- Text input/output
 807
 808 -- Read characters into the provided buffer.  Return when any
 809 -- characters are available; raise an exception if the end of
 810 -- file is reached.
 811 readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
 812 readTextDevice h_@Handle__{..} cbuf = do
 813   --
 814   bbuf0 <- readIORef haByteBuffer
 815
 816   debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
 817         " bbuf=" ++ summaryBuffer bbuf0)
 818
 819   bbuf1 <- if not (isEmptyBuffer bbuf0)
 820               then return bbuf0
 821               else do
 822                    (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
 823                    if r == 0 then ioe_EOF else do  -- raise EOF
 824                    return bbuf1
 825
 826   debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
 827
 828   (bbuf2,cbuf') <-
 829       case haDecoder of
 830           Nothing      -> do
 831                writeIORef haLastDecode (error "codec_state", bbuf1)
 832                latin1_decode bbuf1 cbuf
 833           Just decoder -> do
 834                state <- getState decoder
 835                writeIORef haLastDecode (state, bbuf1)
 836                (streamEncode decoder) bbuf1 cbuf
 837
 838   debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
 839         " bbuf=" ++ summaryBuffer bbuf2)
 840
 841   writeIORef haByteBuffer bbuf2
 842   if bufR cbuf' == bufR cbuf -- no new characters
 843      then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
 844      else return cbuf'
 845
 846 -- we have an incomplete byte sequence at the end of the buffer: try to
 847 -- read more bytes.
 848 readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
 849 readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
 850   --
 851   -- copy the partial sequence to the beginning of the buffer, so we have
 852   -- room to read more bytes.
 853   bbuf1 <- slideContents bbuf0
 854
 855   bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
 856               if r == 0
 857                  then ioe_invalidCharacter
 858                  else return bbuf2
 859
 860   debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
 861
 862   (bbuf3,cbuf') <-
 863       case haDecoder of
 864           Nothing      -> do
 865                writeIORef haLastDecode (error "codec_state", bbuf2)
 866                latin1_decode bbuf2 cbuf
 867           Just decoder -> do
 868                state <- getState decoder
 869                writeIORef haLastDecode (state, bbuf2)
 870                (streamEncode decoder) bbuf2 cbuf
 871
 872   debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++
 873         " bbuf=" ++ summaryBuffer bbuf3)
 874
 875   writeIORef haByteBuffer bbuf3
 876   if bufR cbuf == bufR cbuf'
 877      then readTextDevice' h_ bbuf3 cbuf'
 878      else return cbuf'
 879
 880 -- Read characters into the provided buffer.  Do not block;
 881 -- return zero characters instead.  Raises an exception on end-of-file.
 882 readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
 883 readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
 884   --
 885   bbuf0 <- readIORef haByteBuffer
 886   when (isEmptyBuffer bbuf0) $ do
 887      (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
 888      if isNothing r then ioe_EOF else do  -- raise EOF
 889      writeIORef haByteBuffer bbuf1
 890
 891   decodeByteBuf h_ cbuf
 892
 893 -- Decode bytes from the byte buffer into the supplied CharBuffer.
 894 decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer
 895 decodeByteBuf h_@Handle__{..} cbuf = do
 896   --
 897   bbuf0 <- readIORef haByteBuffer
 898
 899   (bbuf2,cbuf') <-
 900       case haDecoder of
 901           Nothing      -> do
 902                writeIORef haLastDecode (error "codec_state", bbuf0)
 903                latin1_decode bbuf0 cbuf
 904           Just decoder -> do
 905                state <- getState decoder
 906                writeIORef haLastDecode (state, bbuf0)
 907                (streamEncode decoder) bbuf0 cbuf
 908
 909   writeIORef haByteBuffer bbuf2
 910   return cbuf'