GHC/IO/Handle/Internals.hs

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