GHC/IO/Handle/Internals.hs

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