GHC/IO/Handle/Internals.hs

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