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                         haInputNL = inputNL nl,
 525                         haOutputNL = outputNL nl,
 526                         haOtherSide = other_side
 527                       })
 528
 529 -- | makes a new 'Handle'
 530 mkFileHandle :: (IODevice dev, BufferedIO dev, Typeable dev)
 531              => dev -- ^ the underlying IO device, which must support
 532                     -- 'IODevice', 'BufferedIO' and 'Typeable'
 533              -> FilePath
 534                     -- ^ a string describing the 'Handle', e.g. the file
 535                     -- path for a file.  Used in error messages.
 536              -> IOMode
 537                     -- The mode in which the 'Handle' is to be used
 538              -> Maybe TextEncoding
 539                     -- Create the 'Handle' with no text encoding?
 540              -> NewlineMode
 541                     -- Translate newlines?
 542              -> IO Handle
 543 mkFileHandle dev filepath iomode mb_codec tr_newlines = do
 544    mkHandle dev filepath (ioModeToHandleType iomode) True{-buffered-} mb_codec
 545             tr_newlines
 546             (Just handleFinalizer) Nothing{-other_side-}
 547
 548 -- | like 'mkFileHandle', except that a 'Handle' is created with two
 549 -- independent buffers, one for reading and one for writing.  Used for
 550 -- full-dupliex streams, such as network sockets.
 551 mkDuplexHandle :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 552                -> FilePath -> Maybe TextEncoding -> NewlineMode -> IO Handle
 553 mkDuplexHandle dev filepath mb_codec tr_newlines = do
 554
 555   write_side@(FileHandle _ write_m) <-
 556        mkHandle dev filepath WriteHandle True mb_codec
 557                         tr_newlines
 558                         (Just handleFinalizer)
 559                         Nothing -- no othersie
 560
 561   read_side@(FileHandle _ read_m) <-
 562       mkHandle dev filepath ReadHandle True mb_codec
 563                         tr_newlines
 564                         Nothing -- no finalizer
 565                         (Just write_m)
 566
 567   return (DuplexHandle filepath read_m write_m)
 568
 569 ioModeToHandleType :: IOMode -> HandleType
 570 ioModeToHandleType ReadMode      = ReadHandle
 571 ioModeToHandleType WriteMode     = WriteHandle
 572 ioModeToHandleType ReadWriteMode = ReadWriteHandle
 573 ioModeToHandleType AppendMode    = AppendHandle
 574
 575 initBufferState :: HandleType -> BufferState
 576 initBufferState ReadHandle = ReadBuffer
 577 initBufferState _          = WriteBuffer
 578
 579 openTextEncoding
 580    :: Maybe TextEncoding
 581    -> HandleType
 582    -> (forall es ds . Maybe (TextEncoder es) -> Maybe (TextDecoder ds) -> IO a)
 583    -> IO a
 584
 585 openTextEncoding Nothing   ha_type cont = cont Nothing Nothing
 586 openTextEncoding (Just TextEncoding{..}) ha_type cont = do
 587     mb_decoder <- if isReadableHandleType ha_type then do
 588                      decoder <- mkTextDecoder
 589                      return (Just decoder)
 590                   else
 591                      return Nothing
 592     mb_encoder <- if isWritableHandleType ha_type then do
 593                      encoder <- mkTextEncoder
 594                      return (Just encoder)
 595                   else
 596                      return Nothing
 597     cont mb_encoder mb_decoder
 598
 599 -- ---------------------------------------------------------------------------
 600 -- closing Handles
 601
 602 -- hClose_help is also called by lazyRead (in GHC.IO.Handle.Text) when
 603 -- EOF is read or an IO error occurs on a lazy stream.  The
 604 -- semi-closed Handle is then closed immediately.  We have to be
 605 -- careful with DuplexHandles though: we have to leave the closing to
 606 -- the finalizer in that case, because the write side may still be in
 607 -- use.
 608 hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
 609 hClose_help handle_ =
 610   case haType handle_ of
 611       ClosedHandle -> return (handle_,Nothing)
 612       _ -> do mb_exc1 <- trymaybe $ flushWriteBuffer handle_ -- interruptible
 613                     -- it is important that hClose doesn't fail and
 614                     -- leave the Handle open (#3128), so we catch
 615                     -- exceptions when flushing the buffer.
 616               (h_, mb_exc2) <- hClose_handle_ handle_
 617               return (h_, if isJust mb_exc1 then mb_exc1 else mb_exc2)
 618
 619
 620 trymaybe :: IO () -> IO (Maybe SomeException)
 621 trymaybe io = (do io; return Nothing) `catchException` \e -> return (Just e)
 622
 623 hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
 624 hClose_handle_ Handle__{..} = do
 625
 626     -- close the file descriptor, but not when this is the read
 627     -- side of a duplex handle.
 628     -- If an exception is raised by the close(), we want to continue
 629     -- to close the handle and release the lock if it has one, then
 630     -- we return the exception to the caller of hClose_help which can
 631     -- raise it if necessary.
 632     maybe_exception <-
 633       case haOtherSide of
 634         Nothing -> trymaybe $ IODevice.close haDevice
 635         Just _  -> return Nothing
 636
 637     -- free the spare buffers
 638     writeIORef haBuffers BufferListNil
 639     writeIORef haCharBuffer noCharBuffer
 640     writeIORef haByteBuffer noByteBuffer
 641
 642     -- release our encoder/decoder
 643     case haDecoder of Nothing -> return (); Just d -> close d
 644     case haEncoder of Nothing -> return (); Just d -> close d
 645
 646     -- we must set the fd to -1, because the finalizer is going
 647     -- to run eventually and try to close/unlock it.
 648     -- ToDo: necessary?  the handle will be marked ClosedHandle
 649     -- XXX GHC won't let us use record update here, hence wildcards
 650     return (Handle__{ haType = ClosedHandle, .. }, maybe_exception)
 651
 652 {-# NOINLINE noCharBuffer #-}
 653 noCharBuffer :: CharBuffer
 654 noCharBuffer = unsafePerformIO $ newCharBuffer 1 ReadBuffer
 655
 656 {-# NOINLINE noByteBuffer #-}
 657 noByteBuffer :: Buffer Word8
 658 noByteBuffer = unsafePerformIO $ newByteBuffer 1 ReadBuffer
 659
 660 -- ---------------------------------------------------------------------------
 661 -- Looking ahead
 662
 663 hLookAhead_ :: Handle__ -> IO Char
 664 hLookAhead_ handle_@Handle__{..} = do
 665     buf <- readIORef haCharBuffer
 666
 667     -- fill up the read buffer if necessary
 668     new_buf <- if isEmptyBuffer buf
 669                   then readTextDevice handle_ buf
 670                   else return buf
 671     writeIORef haCharBuffer new_buf
 672
 673     peekCharBuf (bufRaw buf) (bufL buf)
 674
 675 -- ---------------------------------------------------------------------------
 676 -- debugging
 677
 678 debugIO :: String -> IO ()
 679 #if defined(DEBUG_DUMP)
 680 debugIO s = do
 681   withCStringLen (s++"\n") $ \(p,len) -> c_write 1 p (fromIntegral len)
 682   return ()
 683 #else
 684 debugIO s = return ()
 685 #endif
 686
 687 -- ----------------------------------------------------------------------------
 688 -- Text input/output
 689
 690 -- Write the contents of the supplied Char buffer to the device, return
 691 -- only when all the data has been written.
 692 writeTextDevice :: Handle__ -> CharBuffer -> IO ()
 693 writeTextDevice h_@Handle__{..} cbuf = do
 694   --
 695   bbuf <- readIORef haByteBuffer
 696
 697   debugIO ("writeTextDevice: cbuf=" ++ summaryBuffer cbuf ++
 698         " bbuf=" ++ summaryBuffer bbuf)
 699
 700   (cbuf',bbuf') <- case haEncoder of
 701     Nothing      -> latin1_encode cbuf bbuf
 702     Just encoder -> (encode encoder) cbuf bbuf
 703
 704   debugIO ("writeTextDevice after encoding: cbuf=" ++ summaryBuffer cbuf' ++
 705         " bbuf=" ++ summaryBuffer bbuf')
 706
 707   Buffered.flushWriteBuffer haDevice bbuf'
 708   writeIORef haByteBuffer bbuf{bufL=0,bufR=0}
 709   if not (isEmptyBuffer cbuf')
 710      then writeTextDevice h_ cbuf'
 711      else return ()
 712
 713 -- Read characters into the provided buffer.  Return when any
 714 -- characters are available; raise an exception if the end of
 715 -- file is reached.
 716 readTextDevice :: Handle__ -> CharBuffer -> IO CharBuffer
 717 readTextDevice h_@Handle__{..} cbuf = do
 718   --
 719   bbuf0 <- readIORef haByteBuffer
 720
 721   debugIO ("readTextDevice: cbuf=" ++ summaryBuffer cbuf ++
 722         " bbuf=" ++ summaryBuffer bbuf0)
 723
 724   bbuf1 <- if not (isEmptyBuffer bbuf0)
 725               then return bbuf0
 726               else do
 727                    (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
 728                    if r == 0 then ioe_EOF else do  -- raise EOF
 729                    return bbuf1
 730
 731   debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf1)
 732
 733   (bbuf2,cbuf') <-
 734       case haDecoder of
 735           Nothing      -> do
 736                writeIORef haLastDecode (error "codec_state", bbuf1)
 737                latin1_decode bbuf1 cbuf
 738           Just decoder -> do
 739                state <- getState decoder
 740                writeIORef haLastDecode (state, bbuf1)
 741                (encode decoder) bbuf1 cbuf
 742
 743   debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
 744         " bbuf=" ++ summaryBuffer bbuf2)
 745
 746   writeIORef haByteBuffer bbuf2
 747   if bufR cbuf' == bufR cbuf -- no new characters
 748      then readTextDevice' h_ bbuf2 cbuf -- we need more bytes to make a Char
 749      else return cbuf'
 750
 751 -- we have an incomplete byte sequence at the end of the buffer: try to
 752 -- read more bytes.
 753 readTextDevice' :: Handle__ -> Buffer Word8 -> CharBuffer -> IO CharBuffer
 754 readTextDevice' h_@Handle__{..} bbuf0 cbuf = do
 755   --
 756   -- copy the partial sequence to the beginning of the buffer, so we have
 757   -- room to read more bytes.
 758   bbuf1 <- slideContents bbuf0
 759
 760   bbuf2 <- do (r,bbuf2) <- Buffered.fillReadBuffer haDevice bbuf1
 761               if r == 0
 762                  then ioe_invalidCharacter
 763                  else return bbuf2
 764
 765   debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2)
 766
 767   (bbuf3,cbuf') <-
 768       case haDecoder of
 769           Nothing      -> do
 770                writeIORef haLastDecode (error "codec_state", bbuf2)
 771                latin1_decode bbuf2 cbuf
 772           Just decoder -> do
 773                state <- getState decoder
 774                writeIORef haLastDecode (state, bbuf2)
 775                (encode decoder) bbuf2 cbuf
 776
 777   debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++
 778         " bbuf=" ++ summaryBuffer bbuf3)
 779
 780   writeIORef haByteBuffer bbuf3
 781   if bufR cbuf == bufR cbuf'
 782      then readTextDevice' h_ bbuf3 cbuf'
 783      else return cbuf'
 784
 785 -- Read characters into the provided buffer.  Do not block;
 786 -- return zero characters instead.  Raises an exception on end-of-file.
 787 readTextDeviceNonBlocking :: Handle__ -> CharBuffer -> IO CharBuffer
 788 readTextDeviceNonBlocking h_@Handle__{..} cbuf = do
 789   --
 790   bbuf0 <- readIORef haByteBuffer
 791   bbuf1 <- if not (isEmptyBuffer bbuf0)
 792               then return bbuf0
 793               else do
 794                    (r,bbuf1) <- Buffered.fillReadBuffer haDevice bbuf0
 795                    if r == 0 then ioe_EOF else do  -- raise EOF
 796                    return bbuf1
 797
 798   (bbuf2,cbuf') <- case haDecoder of
 799                      Nothing      -> latin1_decode bbuf1 cbuf
 800                      Just decoder -> (encode decoder) bbuf1 cbuf
 801
 802   writeIORef haByteBuffer bbuf2
 803   return cbuf'