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