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