GHC/IO/Handle/Internals.hs

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