GHC/IO/Handle/Internals.hs

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