GHC/IO/Handle.hs

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