GHC/IO/Handle.hs

   1 {-# OPTIONS_GHC -XNoImplicitPrelude -XRecordWildCards #-}
   2 {-# OPTIONS_GHC -fno-warn-unused-matches #-}
   3 -----------------------------------------------------------------------------
   4 -- |
   5 -- Module      :  GHC.IO.Handle
   6 -- Copyright   :  (c) The University of Glasgow, 1994-2009
   7 -- License     :  see libraries/base/LICENSE
   8 --
   9 -- Maintainer  :  libraries@haskell.org
  10 -- Stability   :  provisional
  11 -- Portability :  non-portable
  12 --
  13 -- External API for GHC's Handle implementation
  14 --
  15 -----------------------------------------------------------------------------
  16
  17 module GHC.IO.Handle (
  18    Handle,
  19    BufferMode(..),
  20
  21    mkFileHandle, mkDuplexHandle,
  22
  23    hFileSize, hSetFileSize, hIsEOF, hLookAhead,
  24    hSetBuffering, hSetBinaryMode, hSetEncoding, hGetEncoding,
  25    hFlush, hFlushAll, hDuplicate, hDuplicateTo,
  26
  27    hClose, hClose_help,
  28
  29    HandlePosition, HandlePosn(..), hGetPosn, hSetPosn,
  30    SeekMode(..), hSeek, hTell,
  31
  32    hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable,
  33    hSetEcho, hGetEcho, hIsTerminalDevice,
  34
  35    hSetNewlineMode, Newline(..), NewlineMode(..), nativeNewline,
  36    noNewlineTranslation, universalNewlineMode, nativeNewlineMode,
  37
  38    hShow,
  39
  40    hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
  41
  42    hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking
  43  ) where
  44
  45 import GHC.IO
  46 import GHC.IO.Exception
  47 import GHC.IO.Encoding
  48 import GHC.IO.Buffer
  49 import GHC.IO.BufferedIO ( BufferedIO )
  50 import GHC.IO.Device as IODevice
  51 import GHC.IO.Handle.Types
  52 import GHC.IO.Handle.Internals
  53 import GHC.IO.Handle.Text
  54 import qualified GHC.IO.BufferedIO as Buffered
  55
  56 import GHC.Base
  57 import GHC.Exception
  58 import GHC.MVar
  59 import GHC.IORef
  60 import GHC.Show
  61 import GHC.Num
  62 import GHC.Real
  63 import Data.Maybe
  64 import Data.Typeable
  65 import Control.Monad
  66
  67 -- ---------------------------------------------------------------------------
  68 -- Closing a handle
  69
  70 -- | Computation 'hClose' @hdl@ makes handle @hdl@ closed.  Before the
  71 -- computation finishes, if @hdl@ is writable its buffer is flushed as
  72 -- for 'hFlush'.
  73 -- Performing 'hClose' on a handle that has already been closed has no effect;
  74 -- doing so is not an error.  All other operations on a closed handle will fail.
  75 -- If 'hClose' fails for any reason, any further operations (apart from
  76 -- 'hClose') on the handle will still fail as if @hdl@ had been successfully
  77 -- closed.
  78
  79 hClose :: Handle -> IO ()
  80 hClose h@(FileHandle _ m)     = do
  81   mb_exc <- hClose' h m
  82   hClose_maybethrow mb_exc h
  83 hClose h@(DuplexHandle _ r w) = do
  84   mb_exc1 <- hClose' h w
  85   mb_exc2 <- hClose' h r
  86   case mb_exc1 of
  87     Nothing -> return ()
  88     Just e  -> hClose_maybethrow mb_exc2 h
  89
  90 hClose_maybethrow :: Maybe SomeException -> Handle -> IO ()
  91 hClose_maybethrow Nothing  h  = return ()
  92 hClose_maybethrow (Just e) h = hClose_rethrow e h
  93
  94 hClose_rethrow :: SomeException -> Handle -> IO ()
  95 hClose_rethrow e h =
  96   case fromException e of
  97     Just ioe -> ioError (augmentIOError ioe "hClose" h)
  98     Nothing  -> throwIO e
  99
 100 hClose' :: Handle -> MVar Handle__ -> IO (Maybe SomeException)
 101 hClose' h m = withHandle' "hClose" h m $ hClose_help
 102
 103 -----------------------------------------------------------------------------
 104 -- Detecting and changing the size of a file
 105
 106 -- | For a handle @hdl@ which attached to a physical file,
 107 -- 'hFileSize' @hdl@ returns the size of that file in 8-bit bytes.
 108
 109 hFileSize :: Handle -> IO Integer
 110 hFileSize handle =
 111     withHandle_ "hFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
 112     case haType handle_ of
 113       ClosedHandle              -> ioe_closedHandle
 114       SemiClosedHandle          -> ioe_closedHandle
 115       _ -> do flushWriteBuffer handle_
 116               r <- IODevice.getSize dev
 117               if r /= -1
 118                  then return r
 119                  else ioException (IOError Nothing InappropriateType "hFileSize"
 120                                    "not a regular file" Nothing Nothing)
 121
 122
 123 -- | 'hSetFileSize' @hdl@ @size@ truncates the physical file with handle @hdl@ to @size@ bytes.
 124
 125 hSetFileSize :: Handle -> Integer -> IO ()
 126 hSetFileSize handle size =
 127     withHandle_ "hSetFileSize" handle $ \ handle_@Handle__{haDevice=dev} -> do
 128     case haType handle_ of
 129       ClosedHandle              -> ioe_closedHandle
 130       SemiClosedHandle          -> ioe_closedHandle
 131       _ -> do flushWriteBuffer handle_
 132               IODevice.setSize dev size
 133               return ()
 134
 135 -- ---------------------------------------------------------------------------
 136 -- Detecting the End of Input
 137
 138 -- | For a readable handle @hdl@, 'hIsEOF' @hdl@ returns
 139 -- 'True' if no further input can be taken from @hdl@ or for a
 140 -- physical file, if the current I\/O position is equal to the length of
 141 -- the file.  Otherwise, it returns 'False'.
 142 --
 143 -- NOTE: 'hIsEOF' may block, because it has to attempt to read from
 144 -- the stream to determine whether there is any more data to be read.
 145
 146 hIsEOF :: Handle -> IO Bool
 147 hIsEOF handle = wantReadableHandle_ "hIsEOF" handle $ \Handle__{..} -> do
 148
 149   cbuf <- readIORef haCharBuffer
 150   if not (isEmptyBuffer cbuf) then return False else do
 151
 152   bbuf <- readIORef haByteBuffer
 153   if not (isEmptyBuffer bbuf) then return False else do
 154
 155   -- NB. do no decoding, just fill the byte buffer; see #3808
 156   (r,bbuf') <- Buffered.fillReadBuffer haDevice bbuf
 157   if r == 0
 158      then return True
 159      else do writeIORef haByteBuffer bbuf'
 160              return False
 161
 162 -- ---------------------------------------------------------------------------
 163 -- Looking ahead
 164
 165 -- | Computation 'hLookAhead' returns the next character from the handle
 166 -- without removing it from the input buffer, blocking until a character
 167 -- is available.
 168 --
 169 -- This operation may fail with:
 170 --
 171 --  * 'isEOFError' if the end of file has been reached.
 172
 173 hLookAhead :: Handle -> IO Char
 174 hLookAhead handle =
 175   wantReadableHandle_ "hLookAhead"  handle hLookAhead_
 176
 177 -- ---------------------------------------------------------------------------
 178 -- Buffering Operations
 179
 180 -- Three kinds of buffering are supported: line-buffering,
 181 -- block-buffering or no-buffering.  See GHC.IO.Handle for definition and
 182 -- further explanation of what the type represent.
 183
 184 -- | Computation 'hSetBuffering' @hdl mode@ sets the mode of buffering for
 185 -- handle @hdl@ on subsequent reads and writes.
 186 --
 187 -- If the buffer mode is changed from 'BlockBuffering' or
 188 -- 'LineBuffering' to 'NoBuffering', then
 189 --
 190 --  * if @hdl@ is writable, the buffer is flushed as for 'hFlush';
 191 --
 192 --  * if @hdl@ is not writable, the contents of the buffer is discarded.
 193 --
 194 -- This operation may fail with:
 195 --
 196 --  * 'isPermissionError' if the handle has already been used for reading
 197 --    or writing and the implementation does not allow the buffering mode
 198 --    to be changed.
 199
 200 hSetBuffering :: Handle -> BufferMode -> IO ()
 201 hSetBuffering handle mode =
 202   withAllHandles__ "hSetBuffering" handle $ \ handle_@Handle__{..} -> do
 203   case haType of
 204     ClosedHandle -> ioe_closedHandle
 205     _ -> do
 206          if mode == haBufferMode then return handle_ else do
 207
 208          {- Note:
 209             - we flush the old buffer regardless of whether
 210               the new buffer could fit the contents of the old buffer
 211               or not.
 212             - allow a handle's buffering to change even if IO has
 213               occurred (ANSI C spec. does not allow this, nor did
 214               the previous implementation of IO.hSetBuffering).
 215             - a non-standard extension is to allow the buffering
 216               of semi-closed handles to change [sof 6/98]
 217           -}
 218           flushCharBuffer handle_
 219
 220           let state = initBufferState haType
 221               reading = not (isWritableHandleType haType)
 222
 223           new_buf <-
 224             case mode of
 225                 --  See [note Buffer Sizing], GHC.IO.Handle.Types
 226               NoBuffering | reading   -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 227                           | otherwise -> newCharBuffer 1 state
 228               LineBuffering          -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 229               BlockBuffering Nothing -> newCharBuffer dEFAULT_CHAR_BUFFER_SIZE state
 230               BlockBuffering (Just n) | n <= 0    -> ioe_bufsiz n
 231                                       | otherwise -> newCharBuffer n state
 232
 233           writeIORef haCharBuffer new_buf
 234
 235           -- for input terminals we need to put the terminal into
 236           -- cooked or raw mode depending on the type of buffering.
 237           is_tty <- IODevice.isTerminal haDevice
 238           when (is_tty && isReadableHandleType haType) $
 239                 case mode of
 240 #ifndef mingw32_HOST_OS
 241         -- 'raw' mode under win32 is a bit too specialised (and troublesome
 242         -- for most common uses), so simply disable its use here.
 243                   NoBuffering -> IODevice.setRaw haDevice True
 244 #else
 245                   NoBuffering -> return ()
 246 #endif
 247                   _           -> IODevice.setRaw haDevice False
 248
 249           -- throw away spare buffers, they might be the wrong size
 250           writeIORef haBuffers BufferListNil
 251
 252           return Handle__{ haBufferMode = mode,.. }
 253
 254 -- -----------------------------------------------------------------------------
 255 -- hSetEncoding
 256
 257 -- | The action 'hSetEncoding' @hdl@ @encoding@ changes the text encoding
 258 -- for the handle @hdl@ to @encoding@.  The default encoding when a 'Handle' is
 259 -- created is 'localeEncoding', namely the default encoding for the current
 260 -- locale.
 261 --
 262 -- To create a 'Handle' with no encoding at all, use 'openBinaryFile'.  To
 263 -- stop further encoding or decoding on an existing 'Handle', use
 264 -- 'hSetBinaryMode'.
 265 --
 266 -- 'hSetEncoding' may need to flush buffered data in order to change
 267 -- the encoding.
 268 --
 269 hSetEncoding :: Handle -> TextEncoding -> IO ()
 270 hSetEncoding hdl encoding = do
 271   withAllHandles__ "hSetEncoding" hdl $ \h_@Handle__{..} -> do
 272     flushCharBuffer h_
 273     closeTextCodecs h_
 274     openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do
 275     bbuf <- readIORef haByteBuffer
 276     ref <- newIORef (error "last_decode")
 277     return (Handle__{ haLastDecode = ref,
 278                       haDecoder = mb_decoder,
 279                       haEncoder = mb_encoder,
 280                       haCodec   = Just encoding, .. })
 281
 282 -- | Return the current 'TextEncoding' for the specified 'Handle', or
 283 -- 'Nothing' if the 'Handle' is in binary mode.
 284 --
 285 -- Note that the 'TextEncoding' remembers nothing about the state of
 286 -- the encoder/decoder in use on this 'Handle'.  For example, if the
 287 -- encoding in use is UTF-16, then using 'hGetEncoding' and
 288 -- 'hSetEncoding' to save and restore the encoding may result in an
 289 -- extra byte-order-mark being written to the file.
 290 --
 291 hGetEncoding :: Handle -> IO (Maybe TextEncoding)
 292 hGetEncoding hdl =
 293   withHandle_ "hGetEncoding" hdl $ \h_@Handle__{..} -> return haCodec
 294
 295 -- -----------------------------------------------------------------------------
 296 -- hFlush
 297
 298 -- | The action 'hFlush' @hdl@ causes any items buffered for output
 299 -- in handle @hdl@ to be sent immediately to the operating system.
 300 --
 301 -- This operation may fail with:
 302 --
 303 --  * 'isFullError' if the device is full;
 304 --
 305 --  * 'isPermissionError' if a system resource limit would be exceeded.
 306 --    It is unspecified whether the characters in the buffer are discarded
 307 --    or retained under these circumstances.
 308
 309 hFlush :: Handle -> IO ()
 310 hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
 311
 312 -- | The action 'hFlushAll' @hdl@ flushes all buffered data in @hdl@,
 313 -- including any buffered read data.  Buffered read data is flushed
 314 -- by seeking the file position back to the point before the bufferred
 315 -- data was read, and hence only works if @hdl@ is seekable (see
 316 -- 'hIsSeekable').
 317 --
 318 -- This operation may fail with:
 319 --
 320 --  * 'isFullError' if the device is full;
 321 --
 322 --  * 'isPermissionError' if a system resource limit would be exceeded.
 323 --    It is unspecified whether the characters in the buffer are discarded
 324 --    or retained under these circumstances;
 325 --
 326 --  * 'isIllegalOperation' if @hdl@ has buffered read data, and is not
 327 --    seekable.
 328
 329 hFlushAll :: Handle -> IO ()
 330 hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer
 331
 332 -- -----------------------------------------------------------------------------
 333 -- Repositioning Handles
 334
 335 data HandlePosn = HandlePosn Handle HandlePosition
 336
 337 instance Eq HandlePosn where
 338     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 339
 340 instance Show HandlePosn where
 341    showsPrec p (HandlePosn h pos) =
 342         showsPrec p h . showString " at position " . shows pos
 343
 344   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 345   -- We represent it as an Integer on the Haskell side, but
 346   -- cheat slightly in that hGetPosn calls upon a C helper
 347   -- that reports the position back via (merely) an Int.
 348 type HandlePosition = Integer
 349
 350 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
 351 -- @hdl@ as a value of the abstract type 'HandlePosn'.
 352
 353 hGetPosn :: Handle -> IO HandlePosn
 354 hGetPosn handle = do
 355     posn <- hTell handle
 356     return (HandlePosn handle posn)
 357
 358 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
 359 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
 360 -- to the position it held at the time of the call to 'hGetPosn'.
 361 --
 362 -- This operation may fail with:
 363 --
 364 --  * 'isPermissionError' if a system resource limit would be exceeded.
 365
 366 hSetPosn :: HandlePosn -> IO ()
 367 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 368
 369 -- ---------------------------------------------------------------------------
 370 -- hSeek
 371
 372 {- Note:
 373  - when seeking using `SeekFromEnd', positive offsets (>=0) means
 374    seeking at or past EOF.
 375
 376  - we possibly deviate from the report on the issue of seeking within
 377    the buffer and whether to flush it or not.  The report isn't exactly
 378    clear here.
 379 -}
 380
 381 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
 382 -- @hdl@ depending on @mode@.
 383 -- The offset @i@ is given in terms of 8-bit bytes.
 384 --
 385 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
 386 -- in the current buffer will first cause any items in the output buffer to be
 387 -- written to the device, and then cause the input buffer to be discarded.
 388 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
 389 -- subset of the possible positioning operations (for instance, it may only
 390 -- be possible to seek to the end of a tape, or to a positive offset from
 391 -- the beginning or current position).
 392 -- It is not possible to set a negative I\/O position, or for
 393 -- a physical file, an I\/O position beyond the current end-of-file.
 394 --
 395 -- This operation may fail with:
 396 --
 397 --  * 'isIllegalOperationError' if the Handle is not seekable, or does
 398 --     not support the requested seek mode.
 399 --
 400 --  * 'isPermissionError' if a system resource limit would be exceeded.
 401
 402 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 403 hSeek handle mode offset =
 404     wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do
 405     debugIO ("hSeek " ++ show (mode,offset))
 406     buf <- readIORef haCharBuffer
 407
 408     if isWriteBuffer buf
 409         then do flushWriteBuffer handle_
 410                 IODevice.seek haDevice mode offset
 411         else do
 412
 413     let r = bufL buf; w = bufR buf
 414     if mode == RelativeSeek && isNothing haDecoder &&
 415        offset >= 0 && offset < fromIntegral (w - r)
 416         then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset }
 417         else do
 418
 419     flushCharReadBuffer handle_
 420     flushByteReadBuffer handle_
 421     IODevice.seek haDevice mode offset
 422
 423
 424 -- | Computation 'hTell' @hdl@ returns the current position of the
 425 -- handle @hdl@, as the number of bytes from the beginning of
 426 -- the file.  The value returned may be subsequently passed to
 427 -- 'hSeek' to reposition the handle to the current position.
 428 --
 429 -- This operation may fail with:
 430 --
 431 --  * 'isIllegalOperationError' if the Handle is not seekable.
 432 --
 433 hTell :: Handle -> IO Integer
 434 hTell handle =
 435     wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do
 436
 437       posn <- IODevice.tell haDevice
 438
 439       cbuf <- readIORef haCharBuffer
 440       bbuf <- readIORef haByteBuffer
 441
 442       let real_posn
 443            | isWriteBuffer cbuf = posn + fromIntegral (bufR cbuf)
 444            | otherwise = posn - fromIntegral (bufR cbuf - bufL cbuf)
 445                               - fromIntegral (bufR bbuf - bufL bbuf)
 446
 447       debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))
 448       debugIO ("   cbuf: " ++ summaryBuffer cbuf ++
 449             "   bbuf: " ++ summaryBuffer bbuf)
 450
 451       return real_posn
 452
 453 -- -----------------------------------------------------------------------------
 454 -- Handle Properties
 455
 456 -- A number of operations return information about the properties of a
 457 -- handle.  Each of these operations returns `True' if the handle has
 458 -- the specified property, and `False' otherwise.
 459
 460 hIsOpen :: Handle -> IO Bool
 461 hIsOpen handle =
 462     withHandle_ "hIsOpen" handle $ \ handle_ -> do
 463     case haType handle_ of
 464       ClosedHandle         -> return False
 465       SemiClosedHandle     -> return False
 466       _                    -> return True
 467
 468 hIsClosed :: Handle -> IO Bool
 469 hIsClosed handle =
 470     withHandle_ "hIsClosed" handle $ \ handle_ -> do
 471     case haType handle_ of
 472       ClosedHandle         -> return True
 473       _                    -> return False
 474
 475 {- not defined, nor exported, but mentioned
 476    here for documentation purposes:
 477
 478     hSemiClosed :: Handle -> IO Bool
 479     hSemiClosed h = do
 480        ho <- hIsOpen h
 481        hc <- hIsClosed h
 482        return (not (ho || hc))
 483 -}
 484
 485 hIsReadable :: Handle -> IO Bool
 486 hIsReadable (DuplexHandle _ _ _) = return True
 487 hIsReadable handle =
 488     withHandle_ "hIsReadable" handle $ \ handle_ -> do
 489     case haType handle_ of
 490       ClosedHandle         -> ioe_closedHandle
 491       SemiClosedHandle     -> ioe_closedHandle
 492       htype                -> return (isReadableHandleType htype)
 493
 494 hIsWritable :: Handle -> IO Bool
 495 hIsWritable (DuplexHandle _ _ _) = return True
 496 hIsWritable handle =
 497     withHandle_ "hIsWritable" handle $ \ handle_ -> do
 498     case haType handle_ of
 499       ClosedHandle         -> ioe_closedHandle
 500       SemiClosedHandle     -> ioe_closedHandle
 501       htype                -> return (isWritableHandleType htype)
 502
 503 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
 504 -- for @hdl@.
 505
 506 hGetBuffering :: Handle -> IO BufferMode
 507 hGetBuffering handle =
 508     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
 509     case haType handle_ of
 510       ClosedHandle         -> ioe_closedHandle
 511       _ ->
 512            -- We're being non-standard here, and allow the buffering
 513            -- of a semi-closed handle to be queried.   -- sof 6/98
 514           return (haBufferMode handle_)  -- could be stricter..
 515
 516 hIsSeekable :: Handle -> IO Bool
 517 hIsSeekable handle =
 518     withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do
 519     case haType of
 520       ClosedHandle         -> ioe_closedHandle
 521       SemiClosedHandle     -> ioe_closedHandle
 522       AppendHandle         -> return False
 523       _                    -> IODevice.isSeekable haDevice
 524
 525 -- -----------------------------------------------------------------------------
 526 -- Changing echo status (Non-standard GHC extensions)
 527
 528 -- | Set the echoing status of a handle connected to a terminal.
 529
 530 hSetEcho :: Handle -> Bool -> IO ()
 531 hSetEcho handle on = do
 532     isT   <- hIsTerminalDevice handle
 533     if not isT
 534      then return ()
 535      else
 536       withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do
 537       case haType of
 538          ClosedHandle -> ioe_closedHandle
 539          _            -> IODevice.setEcho haDevice on
 540
 541 -- | Get the echoing status of a handle connected to a terminal.
 542
 543 hGetEcho :: Handle -> IO Bool
 544 hGetEcho handle = do
 545     isT   <- hIsTerminalDevice handle
 546     if not isT
 547      then return False
 548      else
 549        withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do
 550        case haType of
 551          ClosedHandle -> ioe_closedHandle
 552          _            -> IODevice.getEcho haDevice
 553
 554 -- | Is the handle connected to a terminal?
 555
 556 hIsTerminalDevice :: Handle -> IO Bool
 557 hIsTerminalDevice handle = do
 558     withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do
 559      case haType of
 560        ClosedHandle -> ioe_closedHandle
 561        _            -> IODevice.isTerminal haDevice
 562
 563 -- -----------------------------------------------------------------------------
 564 -- hSetBinaryMode
 565
 566 -- | Select binary mode ('True') or text mode ('False') on a open handle.
 567 -- (See also 'openBinaryFile'.)
 568 --
 569 -- This has the same effect as calling 'hSetEncoding' with 'latin1', together
 570 -- with 'hSetNewlineMode' with 'noNewlineTranslation'.
 571 --
 572 hSetBinaryMode :: Handle -> Bool -> IO ()
 573 hSetBinaryMode handle bin =
 574   withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->
 575     do
 576          flushCharBuffer h_
 577          closeTextCodecs h_
 578
 579          let mb_te | bin       = Nothing
 580                    | otherwise = Just localeEncoding
 581
 582          openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
 583
 584          -- should match the default newline mode, whatever that is
 585          let nl    | bin       = noNewlineTranslation
 586                    | otherwise = nativeNewlineMode
 587
 588          bbuf <- readIORef haByteBuffer
 589          ref <- newIORef (error "codec_state", bbuf)
 590
 591          return Handle__{ haLastDecode = ref,
 592                           haEncoder  = mb_encoder,
 593                           haDecoder  = mb_decoder,
 594                           haCodec    = mb_te,
 595                           haInputNL  = inputNL nl,
 596                           haOutputNL = outputNL nl, .. }
 597
 598 -- -----------------------------------------------------------------------------
 599 -- hSetNewlineMode
 600
 601 -- | Set the 'NewlineMode' on the specified 'Handle'.  All buffered
 602 -- data is flushed first.
 603 hSetNewlineMode :: Handle -> NewlineMode -> IO ()
 604 hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
 605   withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} ->
 606     do
 607          flushBuffer h_
 608          return h_{ haInputNL=i, haOutputNL=o }
 609
 610 -- -----------------------------------------------------------------------------
 611 -- Duplicating a Handle
 612
 613 -- | Returns a duplicate of the original handle, with its own buffer.
 614 -- The two Handles will share a file pointer, however.  The original
 615 -- handle's buffer is flushed, including discarding any input data,
 616 -- before the handle is duplicated.
 617
 618 hDuplicate :: Handle -> IO Handle
 619 hDuplicate h@(FileHandle path m) = do
 620   withHandle_' "hDuplicate" h m $ \h_ ->
 621       dupHandle path h Nothing h_ (Just handleFinalizer)
 622 hDuplicate h@(DuplexHandle path r w) = do
 623   write_side@(FileHandle _ write_m) <-
 624      withHandle_' "hDuplicate" h w $ \h_ ->
 625         dupHandle path h Nothing h_ (Just handleFinalizer)
 626   read_side@(FileHandle _ read_m) <-
 627     withHandle_' "hDuplicate" h r $ \h_ ->
 628         dupHandle path h (Just write_m) h_  Nothing
 629   return (DuplexHandle path read_m write_m)
 630
 631 dupHandle :: FilePath
 632           -> Handle
 633           -> Maybe (MVar Handle__)
 634           -> Handle__
 635           -> Maybe HandleFinalizer
 636           -> IO Handle
 637 dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do
 638   -- flush the buffer first, so we don't have to copy its contents
 639   flushBuffer h_
 640   case other_side of
 641     Nothing -> do
 642        new_dev <- IODevice.dup haDevice
 643        dupHandle_ new_dev filepath other_side h_ mb_finalizer
 644     Just r  ->
 645        withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do
 646          dupHandle_ dev filepath other_side h_ mb_finalizer
 647
 648 dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 649            -> FilePath
 650            -> Maybe (MVar Handle__)
 651            -> Handle__
 652            -> Maybe HandleFinalizer
 653            -> IO Handle
 654 dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
 655    -- XXX wrong!
 656   let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
 657   mkHandle new_dev filepath haType True{-buffered-} mb_codec
 658       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
 659       mb_finalizer other_side
 660
 661 -- -----------------------------------------------------------------------------
 662 -- Replacing a Handle
 663
 664 {- |
 665 Makes the second handle a duplicate of the first handle.  The second
 666 handle will be closed first, if it is not already.
 667
 668 This can be used to retarget the standard Handles, for example:
 669
 670 > do h <- openFile "mystdout" WriteMode
 671 >    hDuplicateTo h stdout
 672 -}
 673
 674 hDuplicateTo :: Handle -> Handle -> IO ()
 675 hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do
 676  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
 677    _ <- hClose_help h2_
 678    withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
 679      dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
 680 hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do
 681  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
 682    _ <- hClose_help w2_
 683    withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
 684      dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
 685  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
 686    _ <- hClose_help r2_
 687    withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
 688      dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
 689 hDuplicateTo h1 _ =
 690   ioe_dupHandlesNotCompatible h1
 691
 692
 693 ioe_dupHandlesNotCompatible :: Handle -> IO a
 694 ioe_dupHandlesNotCompatible h =
 695    ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
 696                 "handles are incompatible" Nothing Nothing)
 697
 698 dupHandleTo :: FilePath
 699             -> Handle
 700             -> Maybe (MVar Handle__)
 701             -> Handle__
 702             -> Handle__
 703             -> Maybe HandleFinalizer
 704             -> IO Handle__
 705 dupHandleTo filepath h other_side
 706             hto_@Handle__{haDevice=devTo,..}
 707             h_@Handle__{haDevice=dev} mb_finalizer = do
 708   flushBuffer h_
 709   case cast devTo of
 710     Nothing   -> ioe_dupHandlesNotCompatible h
 711     Just dev' -> do
 712       _ <- IODevice.dup2 dev dev'
 713       FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
 714       takeMVar m
 715
 716 -- ---------------------------------------------------------------------------
 717 -- showing Handles.
 718 --
 719 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
 720 -- than the (pure) instance of 'Show' for 'Handle'.
 721
 722 hShow :: Handle -> IO String
 723 hShow h@(FileHandle path _) = showHandle' path False h
 724 hShow h@(DuplexHandle path _ _) = showHandle' path True h
 725
 726 showHandle' :: String -> Bool -> Handle -> IO String
 727 showHandle' filepath is_duplex h =
 728   withHandle_ "showHandle" h $ \hdl_ ->
 729     let
 730      showType | is_duplex = showString "duplex (read-write)"
 731               | otherwise = shows (haType hdl_)
 732     in
 733     return
 734       (( showChar '{' .
 735         showHdl (haType hdl_)
 736             (showString "loc=" . showString filepath . showChar ',' .
 737              showString "type=" . showType . showChar ',' .
 738              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 739       ) "")
 740    where
 741
 742     showHdl :: HandleType -> ShowS -> ShowS
 743     showHdl ht cont =
 744        case ht of
 745         ClosedHandle  -> shows ht . showString "}"
 746         _ -> cont
 747
 748     showBufMode :: Buffer e -> BufferMode -> ShowS
 749     showBufMode buf bmo =
 750       case bmo of
 751         NoBuffering   -> showString "none"
 752         LineBuffering -> showString "line"
 753         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
 754         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
 755       where
 756        def :: Int
 757        def = bufSize buf