GHC/IO/Handle/Internals.hs

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