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