GHC/IO/Handle.hs

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