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