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