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 -- Handle Finalizers
 360
 361 -- For a duplex handle, we arrange that the read side points to the write side
 362 -- (and hence keeps it alive if the read side is alive).  This is done by
 363 -- having the haOtherSide field of the read side point to the read side.
 364 -- The finalizer is then placed on the write side, and the handle only gets
 365 -- finalized once, when both sides are no longer required.
 366
 367 -- NOTE about finalized handles: It's possible that a handle can be
 368 -- finalized and then we try to use it later, for example if the
 369 -- handle is referenced from another finalizer, or from a thread that
 370 -- has become unreferenced and then resurrected (arguably in the
 371 -- latter case we shouldn't finalize the Handle...).  Anyway,
 372 -- we try to emit a helpful message which is better than nothing.
 373 --
 374 -- [later; 8/2010] However, a program like this can yield a strange
 375 -- error message:
 376 --
 377 --   main = writeFile "out" loop
 378 --   loop = let x = x in x
 379 --
 380 -- because the main thread and the Handle are both unreachable at the
 381 -- same time, the Handle may get finalized before the main thread
 382 -- receives the NonTermination exception, and the exception handler
 383 -- will then report an error.  We'd rather this was not an error and
 384 -- the program just prints "<<loop>>".
 385
 386 handleFinalizer :: FilePath -> MVar Handle__ -> IO ()
 387 handleFinalizer fp m = do
 388   handle_ <- takeMVar m
 389   (handle_', _) <- hClose_help handle_
 390   putMVar m handle_'
 391   return ()
 392
 393 -- ---------------------------------------------------------------------------
 394 -- Allocating buffers
 395
 396 -- using an 8k char buffer instead of 32k improved performance for a
 397 -- basic "cat" program by ~30% for me.  --SDM
 398 dEFAULT_CHAR_BUFFER_SIZE :: Int
 399 dEFAULT_CHAR_BUFFER_SIZE = 2048 -- 8k/sizeof(HsChar)
 400
 401 getCharBuffer :: IODevice dev => dev -> BufferState
 402               -> IO (IORef CharBuffer, BufferMode)
 403 getCharBuffer dev state = do
 404   buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 405   ioref  <- newIORef buffer
 406   is_tty <- IODevice.isTerminal dev
 407
 408   let buffer_mode
 409          | is_tty    = LineBuffering
 410          | otherwise = BlockBuffering Nothing
 411
 412   return (ioref, buffer_mode)
 413
 414 mkUnBuffer :: BufferState -> IO (IORef CharBuffer, BufferMode)
 415 mkUnBuffer state = do
 416   buffer <- newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 417               --  See [note Buffer Sizing], GHC.IO.Handle.Types
 418   ref <- newIORef buffer
 419   return (ref, NoBuffering)
 420
 421 -- -----------------------------------------------------------------------------
 422 -- Flushing buffers
 423
 424 -- | syncs the file with the buffer, including moving the
 425 -- file pointer backwards in the case of a read buffer.  This can fail
 426 -- on a non-seekable read Handle.
 427 flushBuffer :: Handle__ -> IO ()
 428 flushBuffer h_@Handle__{..} = do
 429   buf <- readIORef haCharBuffer
 430   case bufState buf of
 431     ReadBuffer  -> do
 432         flushCharReadBuffer h_
 433         flushByteReadBuffer h_
 434     WriteBuffer -> do
 435         flushByteWriteBuffer h_
 436
 437 -- | flushes the Char buffer only.  Works on all Handles.
 438 flushCharBuffer :: Handle__ -> IO ()
 439 flushCharBuffer h_@Handle__{..} = do
 440   cbuf <- readIORef haCharBuffer
 441   case bufState cbuf of
 442     ReadBuffer  -> do
 443         flushCharReadBuffer h_
 444     WriteBuffer ->
 445         when (not (isEmptyBuffer cbuf)) $
 446            error "internal IO library error: Char buffer non-empty"
 447
 448 -- -----------------------------------------------------------------------------
 449 -- Writing data (flushing write buffers)
 450
 451 -- flushWriteBuffer flushes the buffer iff it contains pending write
 452 -- data.  Flushes both the Char and the byte buffer, leaving both
 453 -- empty.
 454 flushWriteBuffer :: Handle__ -> IO ()
 455 flushWriteBuffer h_@Handle__{..} = do
 456   buf <- readIORef haByteBuffer
 457   when (isWriteBuffer buf) $ flushByteWriteBuffer h_
 458
 459 flushByteWriteBuffer :: Handle__ -> IO ()
 460 flushByteWriteBuffer h_@Handle__{..} = do
 461   bbuf <- readIORef haByteBuffer
 462   when (not (isEmptyBuffer bbuf)) $ do
 463     bbuf' <- Buffered.flushWriteBuffer haDevice bbuf
 464     writeIORef haByteBuffer bbuf'
 465
 466 -- write the contents of the CharBuffer to the Handle__.
 467 -- The data will be encoded and pushed to the byte buffer,
 468 -- flushing if the buffer becomes full.
 469 writeCharBuffer :: Handle__ -> CharBuffer -> IO ()
 470 writeCharBuffer h_@Handle__{..} !cbuf = do
 471   --
 472   bbuf <- readIORef haByteBuffer
 473
 474   debugIO ("writeCharBuffer: cbuf=" ++ summaryBuffer cbuf ++
 475         " bbuf=" ++ summaryBuffer bbuf)
 476
 477   (cbuf',bbuf') <- case haEncoder of
 478     Nothing      -> latin1_encode cbuf bbuf
 479     Just encoder -> (encode encoder) cbuf bbuf
 480
 481   debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++
 482         " bbuf=" ++ summaryBuffer bbuf')
 483
 484           -- flush if the write buffer is full
 485   if isFullBuffer bbuf'
 486           --  or we made no progress
 487      || not (isEmptyBuffer cbuf') && bufL cbuf' == bufL cbuf
 488           -- or the byte buffer has more elements than the user wanted buffered
 489      || (case haBufferMode of
 490           BlockBuffering (Just s) -> bufferElems bbuf' >= s
 491           NoBuffering -> True
 492           _other -> False)
 493     then do
 494       bbuf'' <- Buffered.flushWriteBuffer haDevice bbuf'
 495       writeIORef haByteBuffer bbuf''
 496     else
 497       writeIORef haByteBuffer bbuf'
 498
 499   if not (isEmptyBuffer cbuf')
 500      then writeCharBuffer h_ cbuf'
 501      else return ()
 502
 503 -- -----------------------------------------------------------------------------
 504 -- Flushing read buffers
 505
 506 -- It is always possible to flush the Char buffer back to the byte buffer.
 507 flushCharReadBuffer :: Handle__ -> IO ()
 508 flushCharReadBuffer Handle__{..} = do
 509   cbuf <- readIORef haCharBuffer
 510   if isWriteBuffer cbuf || isEmptyBuffer cbuf then return () else do
 511
 512   -- haLastDecode is the byte buffer just before we did our last batch of
 513   -- decoding.  We're going to re-decode the bytes up to the current char,
 514   -- to find out where we should revert the byte buffer to.
 515   (codec_state, bbuf0) <- readIORef haLastDecode
 516
 517   cbuf0 <- readIORef haCharBuffer
 518   writeIORef haCharBuffer cbuf0{ bufL=0, bufR=0 }
 519
 520   -- if we haven't used any characters from the char buffer, then just
 521   -- re-install the old byte buffer.
 522   if bufL cbuf0 == 0
 523      then do writeIORef haByteBuffer bbuf0
 524              return ()
 525      else do
 526
 527   case haDecoder of
 528     Nothing -> do
 529       writeIORef haByteBuffer bbuf0 { bufL = bufL bbuf0 + bufL cbuf0 }
 530       -- no decoder: the number of bytes to decode is the same as the
 531       -- number of chars we have used up.
 532
 533     Just decoder -> do
 534       debugIO ("flushCharReadBuffer re-decode, bbuf=" ++ summaryBuffer bbuf0 ++
 535                " cbuf=" ++ summaryBuffer cbuf0)
 536
 537       -- restore the codec state
 538       setState decoder codec_state
 539
 540       (bbuf1,cbuf1) <- (encode decoder) bbuf0
 541                                cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 }
 542
 543       debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++
 544                " cbuf=" ++ summaryBuffer cbuf1)
 545
 546       writeIORef haByteBuffer bbuf1
 547
 548
 549 -- When flushing the byte read buffer, we seek backwards by the number
 550 -- of characters in the buffer.  The file descriptor must therefore be
 551 -- seekable: attempting to flush the read buffer on an unseekable
 552 -- handle is not allowed.
 553
 554 flushByteReadBuffer :: Handle__ -> IO ()
 555 flushByteReadBuffer h_@Handle__{..} = do
 556   bbuf <- readIORef haByteBuffer
 557
 558   if isEmptyBuffer bbuf then return () else do
 559
 560   seekable <- IODevice.isSeekable haDevice
 561   when (not seekable) $ ioe_cannotFlushNotSeekable
 562
 563   let seek = negate (bufR bbuf - bufL bbuf)
 564
 565   debugIO ("flushByteReadBuffer: new file offset = " ++ show seek)
 566   IODevice.seek haDevice RelativeSeek (fromIntegral seek)
 567
 568   writeIORef haByteBuffer bbuf{ bufL=0, bufR=0 }
 569
 570 -- ----------------------------------------------------------------------------
 571 -- Making Handles
 572
 573 mkHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 574             -> FilePath
 575             -> HandleType
 576             -> Bool                     -- buffered?
 577             -> Maybe TextEncoding
 578             -> NewlineMode
 579             -> Maybe HandleFinalizer
 580             -> Maybe (MVar Handle__)
 581             -> IO Handle
 582
 583 mkHandle dev filepath ha_type buffered mb_codec nl finalizer other_side = do
 584    openTextEncoding mb_codec ha_type $ \ mb_encoder mb_decoder -> do
 585
 586    let buf_state = initBufferState ha_type
 587    bbuf <- Buffered.newBuffer dev buf_state
 588    bbufref <- newIORef bbuf
 589    last_decode <- newIORef (error "codec_state", bbuf)
 590
 591    (cbufref,bmode) <-
 592          if buffered then getCharBuffer dev buf_state
 593                      else mkUnBuffer buf_state
 594
 595    spares <- newIORef BufferListNil
 596    newFileHandle filepath finalizer
 597             (Handle__ { haDevice = dev,
 598                         haType = ha_type,
 599                         haBufferMode = bmode,
 600                         haByteBuffer = bbufref,
 601                         haLastDecode = last_decode,
 602                         haCharBuffer = cbufref,
 603                         haBuffers = spares,
 604                         haEncoder = mb_encoder,
 605                         haDecoder = mb_decoder,
 606                         haCodec = mb_codec,
 607                         haInputNL = inputNL nl,
 608                         haOutputNL = outputNL nl,
 609                         haOtherSide = other_side
 610                       })
 611
 612 -- | makes a new 'Handle'
 613 mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
 614              => dev -- ^ the underlying IO device, which must support
 615                     -- 'IODevice', 'BufferedIO' and 'Typeable'
 616              -> FilePath
 617                     -- ^ a string describing the 'Handle', e.g. the file
 618                     -- path for a file.  Used in error messages.
 619              -> IOMode
 620                     -- The mode in which the 'Handle' is to be used
 621              -> Maybe TextEncoding
 622                     -- Create the 'Handle' with no text encoding?
 623              -> NewlineMode
 624                     -- Translate newlines?
 625              -> IO Handle
 626 mkFileHandle dev filepath iomode mb_codec tr_newlines = do
 627    mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
 628             tr_newlines
 629             (Just handleFinalizer) Nothing{-other_side-}
 630
 631 -- | like 'mkFileHandle', except that a 'Handle' is created with two
 632 -- independent buffers, one for reading and one for writing.  Used for
 633 -- full-duplex streams, such as network sockets.
 634 mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 635                -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
 636 mkDuplexHandle dev filepath mb_codec tr_newlines = do
 637
 638   write_side@(FileHandle _ write_m) <-
 639        mkHandle dev filepath WriteHandle True mb_codec
 640                         tr_newlines
 641                         (Just handleFinalizer)
 642                         Nothing -- no othersie
 643
 644   read_side@(FileHandle _ read_m) <-
 645       mkHandle dev filepath ReadHandle True mb_codec
 646                         tr_newlines
 647                         Nothing -- no finalizer
 648                         (Just write_m)
 649
 650   return (DuplexHandle filepath read_m write_m)
 651
 652 ioModeToHandleType :: IOMode -> HandleType
 653 ioModeToHandleType ReadMode      = ReadHandle
 654 ioModeToHandleType WriteMode     = WriteHandle
 655 ioModeToHandleType ReadWriteMode = ReadWriteHandle
 656 ioModeToHandleType AppendMode    = AppendHandle
 657
 658 initBufferState :: HandleType -> BufferState
 659 initBufferState ReadHandle = ReadBuffer
 660 initBufferState _          = WriteBuffer
 661
 662 openTextEncoding
 663    :: Maybe TextEncoding
 664    -> HandleType
 665    -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
 666    -> IO a
 667
 668 openTextEncoding Nothing   ha_type cont = cont Nothing Nothing
 669 openTextEncoding (Just TextEncoding{..}) ha_type cont = do
 670     mb_decoder <- if isReadableHandleType ha_type then do
 671                      decoder <- mkTextDecoder
 672                      return (Just decoder)
 673                   else
 674                      return Nothing
 675     mb_encoder <- if isWritableHandleType ha_type then do
 676                      encoder <- mkTextEncoder
 677                      return (Just encoder)
 678                   else
 679                      return Nothing
 680     cont mb_encoder mb_decoder
 681
 682 closeTextCodecs :: Handle__ -> IO ()
 683 closeTextCodecs Handle__{..} = do
 684   case haDecoder of Nothing -> return (); Just d -> Encoding.close d
 685   case haEncoder of Nothing -> return (); Just d -> Encoding.close d
 686
 687 -- ---------------------------------------------------------------------------
 688 -- closing Handles
 689
 690 -- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
 691 -- EOF is read or an IO error occurs on a lazy stream.  The
 692 -- semi-closed Handle is then closed immediately.  We have to be
 693 -- careful with DuplexHandles though: we have to leave the closing to
 694 -- the finalizer in that case, because the write side may still be in
 695 -- use.
 696 hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
 697 hClose_help handle_ =
 698   case haType handle_ of
 699       ClosedHandle -> return (handle_,Nothing)
 700       _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
 701                     -- it is important that hClose doesn't fail and
 702                     -- leave the Handle open (#3128), so we catch
 703                     -- exceptions when flushing the buffer.
 704               (h_, mb_exc2) <- hClose_handle_ handle_
 705               return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
 706
 707
 708 trymaybe :: IO () -> IO (Maybe SomeException)
 709 trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
 710
 711 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
 712 hClose_handle_ h_@Handle__{..} = do
 713
 714     -- close the file descriptor, but not when this is the read
 715     -- side of a duplex handle.
 716     -- If an exception is raised by the close(), we want to continue
 717     -- to close the handle and release the lock if it has one, then
 718     -- we return the exception to the caller of hClose_help which can
 719     -- raise it if necessary.
 720     maybe_exception <-
 721       case haOtherSide of
 722         Nothing -> trymaybe $ IODevice.close haDevice
 723         Just _  -> return Nothing
 724
 725     -- free the spare buffers
 726     writeIORef haBuffers BufferListNil
 727     writeIORef haCharBuffer noCharBuffer
 728     writeIORef haByteBuffer noByteBuffer
 729
 730     -- release our encoder/decoder
 731     closeTextCodecs h_
 732
 733     -- we must set the fd to -1, because the finalizer is going
 734     -- to run eventually and try to close/unlock it.
 735     -- ToDo: necessary?  the handle will be marked ClosedHandle
 736     -- XXX GHC won't let us use record update here, hence wildcards
 737     return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
 738
 739 {-# NOINLINE noCharBuffer #-}
 740 noCharBuffer :: CharBuffer
 741 noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
 742
 743 {-# NOINLINE noByteBuffer #-}
 744 noByteBuffer :: Buffer Word8
 745 noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
 746
 747 -- ---------------------------------------------------------------------------
 748 -- Looking ahead
 749
 750 hLookAhead_ :: Handle__ -> IO Char
 751 hLookAhead_ handle_@Handle__{..} = do
 752     buf <- readIORef haCharBuffer
 753
 754     -- fill up the read buffer if necessary
 755     new_buf <- if isEmptyBuffer buf
 756                   then readTextDevice handle_ buf
 757                   else return buf
 758     writeIORef haCharBuffer new_buf
 759
 760     peekCharBuf (bufRaw buf) (bufL buf)
 761
 762 -- ---------------------------------------------------------------------------
 763 -- debugging
 764
 765 debugIO :: String -> IO ()
 766 debugIO s
 767  | c_DEBUG_DUMP
 768     = do _ <- withCStringLen (s ++ "\n") $
 769                   \(p, len) -> c_write 1 (castPtr p) (fromIntegral len)
 770          return ()
 771  | otherwise = return ()
 772
 773 -- ----------------------------------------------------------------------------
 774 -- Text input/output
 775
 776 -- Read characters into the provided buffer.  Return when any
 777 -- characters are available; raise an exception if the end of
 778 -- file is reached.
 779 readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
 780 readTextDevice h_@Handle__{..} cbuf = do
 781   --
 782   bbuf0 <- readIORef haByteBuffer
 783
 784   debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
 785         " bbuf=" ++ summaryBuffer bbuf0)
 786
 787   bbuf1 <- if not (isEmptyBuffer bbuf0)
 788               then return bbuf0
 789               else do
 790                    (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
 791                    if r == 0 then ioe_EOF else do  -- raise EOF
 792                    return bbuf1
 793
 794   debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
 795
 796   (bbuf2,cbuf') <-
 797       case haDecoder of
 798           Nothing      -> do
 799                writeIORef haLastDecode (error "codec_state", bbuf1)
 800                latin1_decode bbuf1 cbuf
 801           Just decoder -> do
 802                state <- getState decoder
 803                writeIORef haLastDecode (state, bbuf1)
 804                (encode decoder) bbuf1 cbuf
 805
 806   debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
 807         " bbuf=" ++ summaryBuffer bbuf2)
 808
 809   writeIORef haByteBuffer bbuf2
 810   if bufR cbuf' == bufR cbuf -- no new characters
 811      then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
 812      else return cbuf'
 813
 814 -- we have an incomplete byte sequence at the end of the buffer: try to
 815 -- read more bytes.
 816 readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
 817 readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
 818   --
 819   -- copy the partial sequence to the beginning of the buffer, so we have
 820   -- room to read more bytes.
 821   bbuf1 <- slideContents bbuf0
 822
 823   bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
 824               if r == 0
 825                  then ioe_invalidCharacter
 826                  else return bbuf2
 827
 828   debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2)
 829
 830   (bbuf3,cbuf') <-
 831       case haDecoder of
 832           Nothing      -> do
 833                writeIORef haLastDecode (error "codec_state", bbuf2)
 834                latin1_decode bbuf2 cbuf
 835           Just decoder -> do
 836                state <- getState decoder
 837                writeIORef haLastDecode (state, bbuf2)
 838                (encode decoder) bbuf2 cbuf
 839
 840   debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++
 841         " bbuf=" ++ summaryBuffer bbuf3)
 842
 843   writeIORef haByteBuffer bbuf3
 844   if bufR cbuf == bufR cbuf'
 845      then readTextDevice' h_ bbuf3 cbuf'
 846      else return cbuf'
 847
 848 -- Read characters into the provided buffer.  Do not block;
 849 -- return zero characters instead.  Raises an exception on end-of-file.
 850 readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
 851 readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
 852   --
 853   bbuf0 <- readIORef haByteBuffer
 854   when (isEmptyBuffer bbuf0) $ do
 855      (r,bbuf1) <- Buffered.fillReadBuffer0 haDevice bbuf0
 856      if isNothing r then ioe_EOF else do  -- raise EOF
 857      writeIORef haByteBuffer bbuf1
 858
 859   decodeByteBuf h_ cbuf
 860
 861 -- Decode bytes from the byte buffer into the supplied CharBuffer.
 862 decodeByteBuf :: Handle__ -> CharBuffer -> IO CharBuffer
 863 decodeByteBuf h_@Handle__{..} cbuf = do
 864   --
 865   bbuf0 <- readIORef haByteBuffer
 866
 867   (bbuf2,cbuf') <-
 868       case haDecoder of
 869           Nothing      -> do
 870                writeIORef haLastDecode (error "codec_state", bbuf0)
 871                latin1_decode bbuf0 cbuf
 872           Just decoder -> do
 873                state <- getState decoder
 874                writeIORef haLastDecode (state, bbuf0)
 875                (encode decoder) bbuf0 cbuf
 876
 877   writeIORef haByteBuffer bbuf2
 878   return cbuf'