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@.  Encodings are available from the
 250 -- module "GHC.IO.Encoding".  The default encoding when a 'Handle' is
 251 -- created is 'localeEncoding', namely the default encoding for the current
 252 -- locale.
 253 --
 254 -- To create a 'Handle' with no encoding at all, use 'openBinaryFile'.  To
 255 -- stop further encoding or decoding on an existing 'Handle', use
 256 -- 'hSetBinaryMode'.
 257 --
 258 hSetEncoding :: Handle -> TextEncoding -> IO ()
 259 hSetEncoding hdl encoding = do
 260   withHandle "hSetEncoding" hdl $ \h_@Handle__{..} -> do
 261     flushCharBuffer h_
 262     openTextEncoding (Just encoding) haType $ \ mb_encoder mb_decoder -> do
 263     bbuf <- readIORef haByteBuffer
 264     ref <- newIORef (error "last_decode")
 265     return (Handle__{ haLastDecode = ref, haDecoder = mb_decoder, haEncoder = mb_encoder, .. },
 266             ())
 267
 268 -- -----------------------------------------------------------------------------
 269 -- hFlush
 270
 271 -- | The action 'hFlush' @hdl@ causes any items buffered for output
 272 -- in handle @hdl@ to be sent immediately to the operating system.
 273 --
 274 -- This operation may fail with:
 275 --
 276 --  * 'isFullError' if the device is full;
 277 --
 278 --  * 'isPermissionError' if a system resource limit would be exceeded.
 279 --    It is unspecified whether the characters in the buffer are discarded
 280 --    or retained under these circumstances.
 281
 282 hFlush :: Handle -> IO ()
 283 hFlush handle = wantWritableHandle "hFlush" handle flushWriteBuffer
 284
 285 -- | The action 'hFlushAll' @hdl@ flushes all buffered data in @hdl@,
 286 -- including any buffered read data.  Buffered read data is flushed
 287 -- by seeking the file position back to the point before the bufferred
 288 -- data was read, and hence only works if @hdl@ is seekable (see
 289 -- 'hIsSeekable').
 290 --
 291 -- This operation may fail with:
 292 --
 293 --  * 'isFullError' if the device is full;
 294 --
 295 --  * 'isPermissionError' if a system resource limit would be exceeded.
 296 --    It is unspecified whether the characters in the buffer are discarded
 297 --    or retained under these circumstances;
 298 --
 299 --  * 'isIllegalOperation' if @hdl@ has buffered read data, and is not
 300 --    seekable.
 301
 302 hFlushAll :: Handle -> IO ()
 303 hFlushAll handle = withHandle_ "hFlushAll" handle flushBuffer
 304
 305 -- -----------------------------------------------------------------------------
 306 -- Repositioning Handles
 307
 308 data HandlePosn = HandlePosn Handle HandlePosition
 309
 310 instance Eq HandlePosn where
 311     (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2
 312
 313 instance Show HandlePosn where
 314    showsPrec p (HandlePosn h pos) =
 315         showsPrec p h . showString " at position " . shows pos
 316
 317   -- HandlePosition is the Haskell equivalent of POSIX' off_t.
 318   -- We represent it as an Integer on the Haskell side, but
 319   -- cheat slightly in that hGetPosn calls upon a C helper
 320   -- that reports the position back via (merely) an Int.
 321 type HandlePosition = Integer
 322
 323 -- | Computation 'hGetPosn' @hdl@ returns the current I\/O position of
 324 -- @hdl@ as a value of the abstract type 'HandlePosn'.
 325
 326 hGetPosn :: Handle -> IO HandlePosn
 327 hGetPosn handle = do
 328     posn <- hTell handle
 329     return (HandlePosn handle posn)
 330
 331 -- | If a call to 'hGetPosn' @hdl@ returns a position @p@,
 332 -- then computation 'hSetPosn' @p@ sets the position of @hdl@
 333 -- to the position it held at the time of the call to 'hGetPosn'.
 334 --
 335 -- This operation may fail with:
 336 --
 337 --  * 'isPermissionError' if a system resource limit would be exceeded.
 338
 339 hSetPosn :: HandlePosn -> IO ()
 340 hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i
 341
 342 -- ---------------------------------------------------------------------------
 343 -- hSeek
 344
 345 {- Note:
 346  - when seeking using `SeekFromEnd', positive offsets (>=0) means
 347    seeking at or past EOF.
 348
 349  - we possibly deviate from the report on the issue of seeking within
 350    the buffer and whether to flush it or not.  The report isn't exactly
 351    clear here.
 352 -}
 353
 354 -- | Computation 'hSeek' @hdl mode i@ sets the position of handle
 355 -- @hdl@ depending on @mode@.
 356 -- The offset @i@ is given in terms of 8-bit bytes.
 357 --
 358 -- If @hdl@ is block- or line-buffered, then seeking to a position which is not
 359 -- in the current buffer will first cause any items in the output buffer to be
 360 -- written to the device, and then cause the input buffer to be discarded.
 361 -- Some handles may not be seekable (see 'hIsSeekable'), or only support a
 362 -- subset of the possible positioning operations (for instance, it may only
 363 -- be possible to seek to the end of a tape, or to a positive offset from
 364 -- the beginning or current position).
 365 -- It is not possible to set a negative I\/O position, or for
 366 -- a physical file, an I\/O position beyond the current end-of-file.
 367 --
 368 -- This operation may fail with:
 369 --
 370 --  * 'isPermissionError' if a system resource limit would be exceeded.
 371
 372 hSeek :: Handle -> SeekMode -> Integer -> IO ()
 373 hSeek handle mode offset =
 374     wantSeekableHandle "hSeek" handle $ \ handle_@Handle__{..} -> do
 375     debugIO ("hSeek " ++ show (mode,offset))
 376     buf <- readIORef haCharBuffer
 377
 378     if isWriteBuffer buf
 379         then do flushWriteBuffer handle_
 380                 IODevice.seek haDevice mode offset
 381         else do
 382
 383     let r = bufL buf; w = bufR buf
 384     if mode == RelativeSeek && isNothing haDecoder &&
 385        offset >= 0 && offset < fromIntegral (w - r)
 386         then writeIORef haCharBuffer buf{ bufL = r + fromIntegral offset }
 387         else do
 388
 389     flushCharReadBuffer handle_
 390     flushByteReadBuffer handle_
 391     IODevice.seek haDevice mode offset
 392
 393
 394 hTell :: Handle -> IO Integer
 395 hTell handle =
 396     wantSeekableHandle "hGetPosn" handle $ \ handle_@Handle__{..} -> do
 397
 398       posn <- IODevice.tell haDevice
 399
 400       cbuf <- readIORef haCharBuffer
 401       bbuf <- readIORef haByteBuffer
 402
 403       let real_posn
 404            | isWriteBuffer cbuf = posn + fromIntegral (bufR cbuf)
 405            | otherwise = posn - fromIntegral (bufR cbuf - bufL cbuf)
 406                               - fromIntegral (bufR bbuf - bufL bbuf)
 407
 408       debugIO ("\nhGetPosn: (posn, real_posn) = " ++ show (posn, real_posn))
 409       debugIO ("   cbuf: " ++ summaryBuffer cbuf ++
 410             "   bbuf: " ++ summaryBuffer bbuf)
 411
 412       return real_posn
 413
 414 -- -----------------------------------------------------------------------------
 415 -- Handle Properties
 416
 417 -- A number of operations return information about the properties of a
 418 -- handle.  Each of these operations returns `True' if the handle has
 419 -- the specified property, and `False' otherwise.
 420
 421 hIsOpen :: Handle -> IO Bool
 422 hIsOpen handle =
 423     withHandle_ "hIsOpen" handle $ \ handle_ -> do
 424     case haType handle_ of
 425       ClosedHandle         -> return False
 426       SemiClosedHandle     -> return False
 427       _                    -> return True
 428
 429 hIsClosed :: Handle -> IO Bool
 430 hIsClosed handle =
 431     withHandle_ "hIsClosed" handle $ \ handle_ -> do
 432     case haType handle_ of
 433       ClosedHandle         -> return True
 434       _                    -> return False
 435
 436 {- not defined, nor exported, but mentioned
 437    here for documentation purposes:
 438
 439     hSemiClosed :: Handle -> IO Bool
 440     hSemiClosed h = do
 441        ho <- hIsOpen h
 442        hc <- hIsClosed h
 443        return (not (ho || hc))
 444 -}
 445
 446 hIsReadable :: Handle -> IO Bool
 447 hIsReadable (DuplexHandle _ _ _) = return True
 448 hIsReadable handle =
 449     withHandle_ "hIsReadable" handle $ \ handle_ -> do
 450     case haType handle_ of
 451       ClosedHandle         -> ioe_closedHandle
 452       SemiClosedHandle     -> ioe_closedHandle
 453       htype                -> return (isReadableHandleType htype)
 454
 455 hIsWritable :: Handle -> IO Bool
 456 hIsWritable (DuplexHandle _ _ _) = return True
 457 hIsWritable handle =
 458     withHandle_ "hIsWritable" handle $ \ handle_ -> do
 459     case haType handle_ of
 460       ClosedHandle         -> ioe_closedHandle
 461       SemiClosedHandle     -> ioe_closedHandle
 462       htype                -> return (isWritableHandleType htype)
 463
 464 -- | Computation 'hGetBuffering' @hdl@ returns the current buffering mode
 465 -- for @hdl@.
 466
 467 hGetBuffering :: Handle -> IO BufferMode
 468 hGetBuffering handle =
 469     withHandle_ "hGetBuffering" handle $ \ handle_ -> do
 470     case haType handle_ of
 471       ClosedHandle         -> ioe_closedHandle
 472       _ ->
 473            -- We're being non-standard here, and allow the buffering
 474            -- of a semi-closed handle to be queried.   -- sof 6/98
 475           return (haBufferMode handle_)  -- could be stricter..
 476
 477 hIsSeekable :: Handle -> IO Bool
 478 hIsSeekable handle =
 479     withHandle_ "hIsSeekable" handle $ \ handle_@Handle__{..} -> do
 480     case haType of
 481       ClosedHandle         -> ioe_closedHandle
 482       SemiClosedHandle     -> ioe_closedHandle
 483       AppendHandle         -> return False
 484       _                    -> IODevice.isSeekable haDevice
 485
 486 -- -----------------------------------------------------------------------------
 487 -- Changing echo status (Non-standard GHC extensions)
 488
 489 -- | Set the echoing status of a handle connected to a terminal.
 490
 491 hSetEcho :: Handle -> Bool -> IO ()
 492 hSetEcho handle on = do
 493     isT   <- hIsTerminalDevice handle
 494     if not isT
 495      then return ()
 496      else
 497       withHandle_ "hSetEcho" handle $ \ Handle__{..} -> do
 498       case haType of
 499          ClosedHandle -> ioe_closedHandle
 500          _            -> IODevice.setEcho haDevice on
 501
 502 -- | Get the echoing status of a handle connected to a terminal.
 503
 504 hGetEcho :: Handle -> IO Bool
 505 hGetEcho handle = do
 506     isT   <- hIsTerminalDevice handle
 507     if not isT
 508      then return False
 509      else
 510        withHandle_ "hGetEcho" handle $ \ Handle__{..} -> do
 511        case haType of
 512          ClosedHandle -> ioe_closedHandle
 513          _            -> IODevice.getEcho haDevice
 514
 515 -- | Is the handle connected to a terminal?
 516
 517 hIsTerminalDevice :: Handle -> IO Bool
 518 hIsTerminalDevice handle = do
 519     withHandle_ "hIsTerminalDevice" handle $ \ Handle__{..} -> do
 520      case haType of
 521        ClosedHandle -> ioe_closedHandle
 522        _            -> IODevice.isTerminal haDevice
 523
 524 -- -----------------------------------------------------------------------------
 525 -- hSetBinaryMode
 526
 527 -- | Select binary mode ('True') or text mode ('False') on a open handle.
 528 -- (See also 'openBinaryFile'.)
 529 --
 530 -- This has the same effect as calling 'hSetEncoding' with 'latin1', together
 531 -- with 'hSetNewlineMode' with 'noNewlineTranslation'.
 532 --
 533 hSetBinaryMode :: Handle -> Bool -> IO ()
 534 hSetBinaryMode handle bin =
 535   withAllHandles__ "hSetBinaryMode" handle $ \ h_@Handle__{..} ->
 536     do
 537          flushBuffer h_
 538
 539          let mb_te | bin       = Nothing
 540                    | otherwise = Just localeEncoding
 541
 542          openTextEncoding mb_te haType $ \ mb_encoder mb_decoder -> do
 543
 544          -- should match the default newline mode, whatever that is
 545          let nl    | bin       = noNewlineTranslation
 546                    | otherwise = nativeNewlineMode
 547
 548          bbuf <- readIORef haByteBuffer
 549          ref <- newIORef (error "codec_state", bbuf)
 550
 551          return Handle__{ haLastDecode = ref,
 552                           haEncoder  = mb_encoder,
 553                           haDecoder  = mb_decoder,
 554                           haInputNL  = inputNL nl,
 555                           haOutputNL = outputNL nl, .. }
 556
 557 -- -----------------------------------------------------------------------------
 558 -- hSetNewlineMode
 559
 560 -- | Set the 'NewlineMode' on the specified 'Handle'.  All buffered
 561 -- data is flushed first.
 562 hSetNewlineMode :: Handle -> NewlineMode -> IO ()
 563 hSetNewlineMode handle NewlineMode{ inputNL=i, outputNL=o } =
 564   withAllHandles__ "hSetNewlineMode" handle $ \h_@Handle__{..} ->
 565     do
 566          flushBuffer h_
 567          return h_{ haInputNL=i, haOutputNL=o }
 568
 569 -- -----------------------------------------------------------------------------
 570 -- Duplicating a Handle
 571
 572 -- | Returns a duplicate of the original handle, with its own buffer.
 573 -- The two Handles will share a file pointer, however.  The original
 574 -- handle's buffer is flushed, including discarding any input data,
 575 -- before the handle is duplicated.
 576
 577 hDuplicate :: Handle -> IO Handle
 578 hDuplicate h@(FileHandle path m) = do
 579   withHandle_' "hDuplicate" h m $ \h_ ->
 580       dupHandle path h Nothing h_ (Just handleFinalizer)
 581 hDuplicate h@(DuplexHandle path r w) = do
 582   write_side@(FileHandle _ write_m) <-
 583      withHandle_' "hDuplicate" h w $ \h_ ->
 584         dupHandle path h Nothing h_ (Just handleFinalizer)
 585   read_side@(FileHandle _ read_m) <-
 586     withHandle_' "hDuplicate" h r $ \h_ ->
 587         dupHandle path h (Just write_m) h_  Nothing
 588   return (DuplexHandle path read_m write_m)
 589
 590 dupHandle :: FilePath
 591           -> Handle
 592           -> Maybe (MVar Handle__)
 593           -> Handle__
 594           -> Maybe HandleFinalizer
 595           -> IO Handle
 596 dupHandle filepath h other_side h_@Handle__{..} mb_finalizer = do
 597   -- flush the buffer first, so we don't have to copy its contents
 598   flushBuffer h_
 599   case other_side of
 600     Nothing -> do
 601        new_dev <- IODevice.dup haDevice
 602        dupHandle_ new_dev filepath other_side h_ mb_finalizer
 603     Just r  ->
 604        withHandle_' "dupHandle" h r $ \Handle__{haDevice=dev} -> do
 605          dupHandle_ dev filepath other_side h_ mb_finalizer
 606
 607 dupHandle_ :: (IODevice dev, BufferedIO dev, Typeable dev) => dev
 608            -> FilePath
 609            -> Maybe (MVar Handle__)
 610            -> Handle__
 611            -> Maybe HandleFinalizer
 612            -> IO Handle
 613 dupHandle_ new_dev filepath other_side h_@Handle__{..} mb_finalizer = do
 614    -- XXX wrong!
 615   let mb_codec = if isJust haEncoder then Just localeEncoding else Nothing
 616   mkHandle new_dev filepath haType True{-buffered-} mb_codec
 617       NewlineMode { inputNL = haInputNL, outputNL = haOutputNL }
 618       mb_finalizer other_side
 619
 620 -- -----------------------------------------------------------------------------
 621 -- Replacing a Handle
 622
 623 {- |
 624 Makes the second handle a duplicate of the first handle.  The second
 625 handle will be closed first, if it is not already.
 626
 627 This can be used to retarget the standard Handles, for example:
 628
 629 > do h <- openFile "mystdout" WriteMode
 630 >    hDuplicateTo h stdout
 631 -}
 632
 633 hDuplicateTo :: Handle -> Handle -> IO ()
 634 hDuplicateTo h1@(FileHandle path m1) h2@(FileHandle _ m2)  = do
 635  withHandle__' "hDuplicateTo" h2 m2 $ \h2_ -> do
 636    _ <- hClose_help h2_
 637    withHandle_' "hDuplicateTo" h1 m1 $ \h1_ -> do
 638      dupHandleTo path h1 Nothing h2_ h1_ (Just handleFinalizer)
 639 hDuplicateTo h1@(DuplexHandle path r1 w1) h2@(DuplexHandle _ r2 w2)  = do
 640  withHandle__' "hDuplicateTo" h2 w2  $ \w2_ -> do
 641    _ <- hClose_help w2_
 642    withHandle_' "hDuplicateTo" h1 w1 $ \w1_ -> do
 643      dupHandleTo path h1 Nothing w2_ w1_ (Just handleFinalizer)
 644  withHandle__' "hDuplicateTo" h2 r2  $ \r2_ -> do
 645    _ <- hClose_help r2_
 646    withHandle_' "hDuplicateTo" h1 r1 $ \r1_ -> do
 647      dupHandleTo path h1 (Just w1) r2_ r1_ Nothing
 648 hDuplicateTo h1 _ =
 649   ioe_dupHandlesNotCompatible h1
 650
 651
 652 ioe_dupHandlesNotCompatible :: Handle -> IO a
 653 ioe_dupHandlesNotCompatible h =
 654    ioException (IOError (Just h) IllegalOperation "hDuplicateTo"
 655                 "handles are incompatible" Nothing Nothing)
 656
 657 dupHandleTo :: FilePath
 658             -> Handle
 659             -> Maybe (MVar Handle__)
 660             -> Handle__
 661             -> Handle__
 662             -> Maybe HandleFinalizer
 663             -> IO Handle__
 664 dupHandleTo filepath h other_side
 665             hto_@Handle__{haDevice=devTo,..}
 666             h_@Handle__{haDevice=dev} mb_finalizer = do
 667   flushBuffer h_
 668   case cast devTo of
 669     Nothing   -> ioe_dupHandlesNotCompatible h
 670     Just dev' -> do
 671       _ <- IODevice.dup2 dev dev'
 672       FileHandle _ m <- dupHandle_ dev' filepath other_side h_ mb_finalizer
 673       takeMVar m
 674
 675 -- ---------------------------------------------------------------------------
 676 -- showing Handles.
 677 --
 678 -- | 'hShow' is in the 'IO' monad, and gives more comprehensive output
 679 -- than the (pure) instance of 'Show' for 'Handle'.
 680
 681 hShow :: Handle -> IO String
 682 hShow h@(FileHandle path _) = showHandle' path False h
 683 hShow h@(DuplexHandle path _ _) = showHandle' path True h
 684
 685 showHandle' :: String -> Bool -> Handle -> IO String
 686 showHandle' filepath is_duplex h =
 687   withHandle_ "showHandle" h $ \hdl_ ->
 688     let
 689      showType | is_duplex = showString "duplex (read-write)"
 690               | otherwise = shows (haType hdl_)
 691     in
 692     return
 693       (( showChar '{' .
 694         showHdl (haType hdl_)
 695             (showString "loc=" . showString filepath . showChar ',' .
 696              showString "type=" . showType . showChar ',' .
 697              showString "buffering=" . showBufMode (unsafePerformIO (readIORef (haCharBuffer hdl_))) (haBufferMode hdl_) . showString "}" )
 698       ) "")
 699    where
 700
 701     showHdl :: HandleType -> ShowS -> ShowS
 702     showHdl ht cont =
 703        case ht of
 704         ClosedHandle  -> shows ht . showString "}"
 705         _ -> cont
 706
 707     showBufMode :: Buffer e -> BufferMode -> ShowS
 708     showBufMode buf bmo =
 709       case bmo of
 710         NoBuffering   -> showString "none"
 711         LineBuffering -> showString "line"
 712         BlockBuffering (Just n) -> showString "block " . showParen True (shows n)
 713         BlockBuffering Nothing  -> showString "block " . showParen True (shows def)
 714       where
 715        def :: Int
 716        def = bufSize buf