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